summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h54
-rw-r--r--generic/tclAssembly.c12
-rw-r--r--generic/tclBasic.c13
-rw-r--r--generic/tclCmdIL.c4
-rw-r--r--generic/tclCompExpr.c7
-rw-r--r--generic/tclCompile.c147
-rw-r--r--generic/tclCompile.h8
-rw-r--r--generic/tclEncoding.c1
-rw-r--r--generic/tclEvent.c3
-rw-r--r--generic/tclExecute.c48
-rw-r--r--generic/tclHash.c37
-rw-r--r--generic/tclIOCmd.c45
-rw-r--r--generic/tclIOSock.c2
-rw-r--r--generic/tclInt.h15
-rw-r--r--generic/tclInterp.c12
-rw-r--r--generic/tclMain.c27
-rw-r--r--generic/tclOO.c4
-rw-r--r--generic/tclObj.c2
-rw-r--r--generic/tclParse.c162
-rw-r--r--generic/tclPkg.c2
-rw-r--r--generic/tclStringObj.c87
-rw-r--r--generic/tclStringRep.h2
-rw-r--r--generic/tclStubLib.c20
-rw-r--r--generic/tclTest.c71
-rw-r--r--generic/tclThreadTest.c6
-rw-r--r--generic/tclTimer.c2
-rw-r--r--generic/tclTrace.c2
-rw-r--r--generic/tclUtf.c22
-rw-r--r--generic/tclVar.c100
29 files changed, 372 insertions, 545 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index 3490049..6061ea8 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -38,8 +38,8 @@ extern "C" {
* update the version numbers:
*
* library/init.tcl (1 LOC patch)
- * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch)
- * win/configure.in (as above)
+ * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch)
+ * win/configure.ac (as above)
* win/tcl.m4 (not patchlevel)
* win/makefile.bc (not patchlevel) 2 LOC
* README (sections 0 and 2, with and without separator)
@@ -54,12 +54,12 @@ extern "C" {
*/
#define TCL_MAJOR_VERSION 8
-#define TCL_MINOR_VERSION 6
-#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL 5
+#define TCL_MINOR_VERSION 7
+#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE
+#define TCL_RELEASE_SERIAL 0
-#define TCL_VERSION "8.6"
-#define TCL_PATCH_LEVEL "8.6.5"
+#define TCL_VERSION "8.7"
+#define TCL_PATCH_LEVEL "8.7a0"
/*
*----------------------------------------------------------------------------
@@ -144,6 +144,7 @@ extern "C" {
#if defined(__GNUC__) && (__GNUC__ > 2)
# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b)))
# define TCL_NORETURN __attribute__ ((noreturn))
+# define TCL_NOINLINE __attribute__ ((noinline))
# if defined(BUILD_tcl) || defined(BUILD_tk)
# define TCL_NORETURN1 __attribute__ ((noreturn))
# else
@@ -153,8 +154,10 @@ extern "C" {
# define TCL_FORMAT_PRINTF(a,b)
# if defined(_MSC_VER) && (_MSC_VER >= 1310)
# define TCL_NORETURN _declspec(noreturn)
+# define TCL_NOINLINE __declspec(noinline)
# else
# define TCL_NORETURN /* nothing */
+# define TCL_NOINLINE /* nothing */
# endif
# define TCL_NORETURN1 /* nothing */
#endif
@@ -1165,18 +1168,6 @@ typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr,
typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *hPtr);
/*
- * This flag controls whether the hash table stores the hash of a key, or
- * recalculates it. There should be no reason for turning this flag off as it
- * is completely binary and source compatible unless you directly access the
- * bucketPtr member of the Tcl_HashTableEntry structure. This member has been
- * removed and the space used to store the hash value.
- */
-
-#ifndef TCL_HASH_KEY_STORE_HASH
-# define TCL_HASH_KEY_STORE_HASH 1
-#endif
-
-/*
* Structure definition for an entry in a hash table. No-one outside Tcl
* should access any of these fields directly; use the macros defined below.
*/
@@ -1185,15 +1176,9 @@ struct Tcl_HashEntry {
Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket,
* or NULL for end of chain. */
Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
-#if TCL_HASH_KEY_STORE_HASH
void *hash; /* Hash value, stored as pointer to ensure
* that the offsets of the fields in this
* structure are not changed. */
-#else
- Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first
- * entry in this entry's chain: used for
- * deleting the entry. */
-#endif
ClientData clientData; /* Application stores something here with
* Tcl_SetHashValue. */
union { /* Key has one of these forms: */
@@ -2392,9 +2377,6 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
*----------------------------------------------------------------------------
* The following constant is used to test for older versions of Tcl in the
* stubs tables.
- *
- * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different
- * value since the stubs tables don't match.
*/
#define TCL_STUB_MAGIC ((int) 0xFCA3BACF)
@@ -2407,17 +2389,19 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
*/
const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version,
- int exact);
+ int exact, int magic);
const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
const char *version, int epoch, int revision);
-/*
- * When not using stubs, make it a macro.
- */
-
-#ifndef USE_TCL_STUBS
+#ifdef USE_TCL_STUBS
+#define Tcl_InitStubs(interp, version, exact) \
+ (Tcl_InitStubs)(interp, version, \
+ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
+ TCL_STUB_MAGIC)
+#else
#define Tcl_InitStubs(interp, version, exact) \
- Tcl_PkgInitStubsCheck(interp, version, exact)
+ Tcl_PkgInitStubsCheck(interp, version, \
+ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
#endif
/*
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index f56da8f..8dd23a0 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -866,7 +866,7 @@ CompileAssembleObj(
* Not valid, so free it and regenerate.
*/
- FreeAssembleCodeInternalRep(objPtr);
+ TclFreeIntRep(objPtr);
}
/*
@@ -891,15 +891,13 @@ CompileAssembleObj(
*/
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &assembleCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &assembleCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
/*
* Record the local variable context to which the bytecode pertains
*/
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -4315,11 +4313,7 @@ FreeAssembleCodeInternalRep(
{
ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
- }
- objPtr->typePtr = NULL;
+ TclReleaseByteCode(codePtr);
}
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d6a460d..a0b5505 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -579,11 +579,12 @@ Tcl_CreateInterp(void)
iPtr->packageUnknown = NULL;
/* TIP #268 */
+#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE)
if (getenv("TCL_PKG_PREFER_LATEST") == NULL) {
iPtr->packagePrefer = PKG_PREFER_STABLE;
- } else {
+ } else
+#endif
iPtr->packagePrefer = PKG_PREFER_LATEST;
- }
iPtr->cmdCount = 0;
TclInitLiteralTable(&iPtr->literalTable);
@@ -939,8 +940,8 @@ Tcl_CreateInterp(void)
* Set up other variables such as tcl_version and tcl_library
*/
- Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY);
Tcl_TraceVar2(interp, "tcl_precision", NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
TclPrecTraceProc, NULL);
@@ -6846,7 +6847,7 @@ Tcl_VarEvalVA(
Tcl_DStringAppend(&buf, string, -1);
}
- result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
+ result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
Tcl_DStringFree(&buf);
return result;
}
@@ -6916,7 +6917,7 @@ Tcl_GlobalEval(
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = iPtr->rootFramePtr;
- result = Tcl_Eval(interp, command);
+ result = Tcl_EvalEx(interp, command, -1, 0);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 0a1b4fe..7420538 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1677,7 +1677,7 @@ InfoLibraryCmd(
return TCL_ERROR;
}
- libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
+ libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
if (libDirName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
@@ -1803,7 +1803,7 @@ InfoPatchLevelCmd(
return TCL_ERROR;
}
- patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
+ patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL,
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (patchlevel != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1));
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 4390282..654666a 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2181,7 +2181,6 @@ ExecConstantExprTree(
CompileEnv *envPtr;
ByteCode *byteCodePtr;
int code;
- Tcl_Obj *byteCodeObj = Tcl_NewObj();
NRE_callback *rootPtr = TOP_CB(interp);
/*
@@ -2195,14 +2194,12 @@ ExecConstantExprTree(
CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr,
0 /* optimize */);
TclEmitOpcode(INST_DONE, envPtr);
- Tcl_IncrRefCount(byteCodeObj);
- TclInitByteCodeObj(byteCodeObj, envPtr);
+ byteCodePtr = TclInitByteCode(envPtr);
TclFreeCompileEnv(envPtr);
TclStackFree(interp, envPtr);
- byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1;
TclNRExecuteByteCode(interp, byteCodePtr);
code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
- Tcl_DecrRefCount(byteCodeObj);
+ TclReleaseByteCode(byteCodePtr);
return code;
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c0203dd..b1b67a8 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -661,6 +661,7 @@ InstructionDesc const tclInstructionTable[] = {
* Prototypes for procedures defined later in this file:
*/
+static void CleanupByteCode(ByteCode *codePtr);
static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
static void DupByteCodeInternalRep(Tcl_Obj *srcPtr,
@@ -676,6 +677,7 @@ static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
static int GetCmdLocEncodingSize(CompileEnv *envPtr);
static int IsCompactibleCompileEnv(Tcl_Interp *interp,
CompileEnv *envPtr);
+static void PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
static void RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
@@ -866,7 +868,7 @@ TclSetByteCodeFromAny(
#endif /*TCL_COMPILE_DEBUG*/
if (result == TCL_OK) {
- TclInitByteCodeObj(objPtr, &compEnv);
+ (void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv);
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile >= 2) {
TclPrintByteCodeObj(interp, objPtr);
@@ -967,16 +969,13 @@ FreeByteCodeInternalRep(
{
register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
}
/*
*----------------------------------------------------------------------
*
- * TclCleanupByteCode --
+ * TclReleaseByteCode --
*
* This procedure does all the real work of freeing up a bytecode
* object's ByteCode structure. It's called only when the structure's
@@ -993,7 +992,26 @@ FreeByteCodeInternalRep(
*/
void
-TclCleanupByteCode(
+TclPreserveByteCode(
+ register ByteCode *codePtr)
+{
+ codePtr->refCount++;
+}
+
+void
+TclReleaseByteCode(
+ register ByteCode *codePtr)
+{
+ if (--codePtr->refCount) {
+ return;
+ }
+
+ /* Just dropped to refcount==0. Clean up. */
+ CleanupByteCode(codePtr);
+}
+
+static void
+CleanupByteCode(
register ByteCode *codePtr) /* Points to the ByteCode to free. */
{
Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
@@ -1260,8 +1278,6 @@ Tcl_NRSubstObj(
*
* Results:
* A (ByteCode *) is returned pointing to the resulting ByteCode.
- * The caller must manage its refCount and arrange for a call to
- * TclCleanupByteCode() when the last reference disappears.
*
* Side effects:
* The Tcl_ObjType of objPtr is changed to the "substcode" type, and the
@@ -1292,7 +1308,7 @@ CompileSubstObj(
|| (codePtr->nsEpoch != nsPtr->resolverEpoch)
|| (codePtr->localCachePtr !=
iPtr->varFramePtr->localCachePtr)) {
- FreeSubstCodeInternalRep(objPtr);
+ TclFreeIntRep(objPtr);
}
}
if (objPtr->typePtr != &substCodeType) {
@@ -1306,11 +1322,9 @@ CompileSubstObj(
TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv);
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &substCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags);
if (iPtr->varFramePtr->localCachePtr) {
@@ -1353,10 +1367,7 @@ FreeSubstCodeInternalRep(
{
register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
}
static void
@@ -2697,11 +2708,40 @@ TclCompileNoOp(
*----------------------------------------------------------------------
*/
-void
-TclInitByteCodeObj(
- Tcl_Obj *objPtr, /* Points object that should be initialized,
- * and whose string rep contains the source
- * code. */
+static void
+PreventCycle(
+ Tcl_Obj *objPtr,
+ CompileEnv *envPtr)
+{
+ int i;
+
+ for (i = 0; i < envPtr->literalArrayNext; i++) {
+ if (objPtr == TclFetchLiteral(envPtr, i)) {
+ /*
+ * Prevent circular reference where the bytecode intrep of
+ * a value contains a literal which is that same value.
+ * If this is allowed to happen, refcount decrements may not
+ * reach zero, and memory may leak. Bugs 467523, 3357771
+ *
+ * NOTE: [Bugs 3392070, 3389764] We make a copy based completely
+ * on the string value, and do not call Tcl_DuplicateObj() so we
+ * can be sure we do not have any lingering cycles hiding in
+ * the intrep.
+ */
+ int numBytes;
+ const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
+ Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes);
+
+ Tcl_IncrRefCount(copyPtr);
+ TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr);
+
+ envPtr->literalArrayPtr[i].objPtr = copyPtr;
+ }
+ }
+}
+
+ByteCode *
+TclInitByteCode(
register CompileEnv *envPtr)/* Points to the CompileEnv structure from
* which to create a ByteCode structure. */
{
@@ -2752,7 +2792,8 @@ TclInitByteCodeObj(
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = namespacePtr;
codePtr->nsEpoch = namespacePtr->resolverEpoch;
- codePtr->refCount = 1;
+ codePtr->refCount = 0;
+ TclPreserveByteCode(codePtr);
if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) {
codePtr->flags = TCL_BYTECODE_RESOLVE_VARS;
} else {
@@ -2778,29 +2819,7 @@ TclInitByteCodeObj(
p += TCL_ALIGN(codeBytes); /* align object array */
codePtr->objArrayPtr = (Tcl_Obj **) p;
for (i = 0; i < numLitObjects; i++) {
- Tcl_Obj *fetched = TclFetchLiteral(envPtr, i);
-
- if (objPtr == fetched) {
- /*
- * Prevent circular reference where the bytecode intrep of
- * a value contains a literal which is that same value.
- * If this is allowed to happen, refcount decrements may not
- * reach zero, and memory may leak. Bugs 467523, 3357771
- *
- * NOTE: [Bugs 3392070, 3389764] We make a copy based completely
- * on the string value, and do not call Tcl_DuplicateObj() so we
- * can be sure we do not have any lingering cycles hiding in
- * the intrep.
- */
- int numBytes;
- const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
-
- codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes);
- Tcl_IncrRefCount(codePtr->objArrayPtr[i]);
- TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr);
- } else {
- codePtr->objArrayPtr[i] = fetched;
- }
+ codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i);
}
p += TCL_ALIGN(objArrayBytes); /* align exception range array */
@@ -2843,15 +2862,6 @@ TclInitByteCodeObj(
#endif /* TCL_COMPILE_STATS */
/*
- * Free the old internal rep then convert the object to a bytecode object
- * by making its internal rep point to the just compiled ByteCode.
- */
-
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
- objPtr->typePtr = &tclByteCodeType;
-
- /*
* TIP #280. Associate the extended per-word line information with the
* byte code object (internal rep), for use with the bc compiler.
*/
@@ -2864,6 +2874,33 @@ TclInitByteCodeObj(
envPtr->iPtr = NULL;
codePtr->localCachePtr = NULL;
+ return codePtr;
+}
+
+ByteCode *
+TclInitByteCodeObj(
+ Tcl_Obj *objPtr, /* Points object that should be initialized,
+ * and whose string rep contains the source
+ * code. */
+ const Tcl_ObjType *typePtr,
+ register CompileEnv *envPtr)/* Points to the CompileEnv structure from
+ * which to create a ByteCode structure. */
+{
+ ByteCode *codePtr;
+
+ PreventCycle(objPtr, envPtr);
+
+ codePtr = TclInitByteCode(envPtr);
+
+ /*
+ * Free the old internal rep then convert the object to a bytecode object
+ * by making its internal rep point to the just compiled ByteCode.
+ */
+
+ TclFreeIntRep(objPtr);
+ objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
+ objPtr->typePtr = typePtr;
+ return codePtr;
}
/*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index d5bc86b..f99c07c 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1067,7 +1067,6 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp,
Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
CompileEnv *envPtr);
-MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr);
MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr,
ExceptionAux *auxPtr);
MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp,
@@ -1119,8 +1118,9 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
int distThreshold);
MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr);
MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
-MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr,
- CompileEnv *envPtr);
+MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr);
+MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp,
CompileEnv *envPtr, const char *string,
int numBytes, const CmdFrame *invoker, int word);
@@ -1157,6 +1157,8 @@ MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
int flags, int *localIndexPtr,
int *isScalarPtr);
+MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr);
+MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr);
MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp,
const char *name, Namespace *nsPtr);
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 4edebcf..32055a3 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -355,6 +355,7 @@ DupEncodingIntRep(
Tcl_Obj *dupPtr)
{
dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes);
+ dupPtr->typePtr = &encodingType;
}
/*
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index b0b8188..0eabc13 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1043,6 +1043,9 @@ TclInitSubsystems(void)
#if USE_TCLALLOC
TclInitAlloc(); /* Process wide mutex init */
#endif
+#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+ TclpInitAllocCache();
+#endif
#ifdef TCL_MEM_DEBUG
TclInitDbCkalloc(); /* Process wide mutex init */
#endif
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 1389382..df0618c 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -35,14 +35,14 @@
#endif
/*
- * A mask (should be 2**n-1) that is used to work out when the bytecode engine
- * should call Tcl_AsyncReady() to see whether there is a signal that needs
- * handling.
+ * A counter that is used to work out when the bytecode engine should call
+ * Tcl_AsyncReady() to see whether there is a signal that needs handling, and
+ * other expensive periodic operations.
*/
-#ifndef ASYNC_CHECK_COUNT_MASK
-# define ASYNC_CHECK_COUNT_MASK 63
-#endif /* !ASYNC_CHECK_COUNT_MASK */
+#ifndef ASYNC_CHECK_COUNT
+# define ASYNC_CHECK_COUNT 64
+#endif /* !ASYNC_CHECK_COUNT */
/*
* Boolean flag indicating whether the Tcl bytecode interpreter has been
@@ -1499,11 +1499,9 @@ ExprObjCallback(
*
* Results:
* A (ByteCode *) is returned pointing to the resulting ByteCode.
- * The caller must manage its refCount and arrange for a call to
- * TclCleanupByteCode() when the last reference disappears.
*
* Side effects:
- * The Tcl_ObjType of objPtr is changed to the "bytecode" type,
+ * The Tcl_ObjType of objPtr is changed to the "exprcode" type,
* and the ByteCode is kept in the internal rep (along with context
* data for checking validity) for faster operations the next time
* CompileExprObj is called on the same value.
@@ -1536,7 +1534,7 @@ CompileExprObj(
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
|| (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
- FreeExprCodeInternalRep(objPtr);
+ TclFreeIntRep(objPtr);
}
}
if (objPtr->typePtr != &exprCodeType) {
@@ -1567,10 +1565,8 @@ CompileExprObj(
*/
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &exprCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1644,10 +1640,7 @@ FreeExprCodeInternalRep(
{
ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
}
/*
@@ -2033,7 +2026,7 @@ TclNRExecuteByteCode(
* sizeof(void *);
int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
- codePtr->refCount++;
+ TclPreserveByteCode(codePtr);
/*
* Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
@@ -2115,8 +2108,14 @@ TEBCresume(
* sporadically: no special need for speed.
*/
- int instructionCount = 0; /* Counter that is used to work out when to
- * call Tcl_AsyncReady() */
+ unsigned interruptCounter = 1;
+ /* Counter that is used to work out when to
+ * call Tcl_AsyncReady(). This must be 1
+ * initially so that we call the async-check
+ * stanza early, otherwise there are command
+ * sequences that can make the interpreter
+ * busy-loop without an opportunity to
+ * recognise an interrupt. */
const char *curInstName;
#ifdef TCL_COMPILE_DEBUG
int traceInstructions; /* Whether we are doing instruction-level
@@ -2314,10 +2313,11 @@ TEBCresume(
/*
* Check for asynchronous handlers [Bug 746722]; we do the check every
- * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
+ * ASYNC_CHECK_COUNT instructions.
*/
- if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
+ if ((--interruptCounter) == 0) {
+ interruptCounter = ASYNC_CHECK_COUNT;
DECACHE_STACK_INFO();
if (TclAsyncReady(iPtr)) {
result = Tcl_AsyncInvoke(interp, result);
@@ -8185,9 +8185,7 @@ TEBCresume(
}
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
TclStackFree(interp, TD); /* free my stack */
return result;
diff --git a/generic/tclHash.c b/generic/tclHash.c
index 1991aea..3ea9dd9 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -321,11 +321,9 @@ CreateHashEntry(
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
-#if TCL_HASH_KEY_STORE_HASH
if (hash != PTR2UINT(hPtr->hash)) {
continue;
}
-#endif
if (((void *) key == hPtr) || compareKeysProc((void *) key, hPtr)) {
if (newPtr) {
*newPtr = 0;
@@ -336,11 +334,9 @@ CreateHashEntry(
} else {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
-#if TCL_HASH_KEY_STORE_HASH
if (hash != PTR2UINT(hPtr->hash)) {
continue;
}
-#endif
if (key == hPtr->key.oneWordValue) {
if (newPtr) {
*newPtr = 0;
@@ -368,15 +364,9 @@ CreateHashEntry(
}
hPtr->tablePtr = tablePtr;
-#if TCL_HASH_KEY_STORE_HASH
hPtr->hash = UINT2PTR(hash);
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
-#else
- hPtr->bucketPtr = &tablePtr->buckets[index];
- hPtr->nextPtr = *hPtr->bucketPtr;
- *hPtr->bucketPtr = hPtr;
-#endif
tablePtr->numEntries++;
/*
@@ -416,9 +406,7 @@ Tcl_DeleteHashEntry(
const Tcl_HashKeyType *typePtr;
Tcl_HashTable *tablePtr;
Tcl_HashEntry **bucketPtr;
-#if TCL_HASH_KEY_STORE_HASH
int index;
-#endif
tablePtr = entryPtr->tablePtr;
@@ -433,7 +421,6 @@ Tcl_DeleteHashEntry(
typePtr = &tclArrayHashKeyType;
}
-#if TCL_HASH_KEY_STORE_HASH
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash));
@@ -442,9 +429,6 @@ Tcl_DeleteHashEntry(
}
bucketPtr = &tablePtr->buckets[index];
-#else
- bucketPtr = entryPtr->bucketPtr;
-#endif
if (*bucketPtr == entryPtr) {
*bucketPtr = entryPtr->nextPtr;
@@ -1062,7 +1046,6 @@ RebuildTable(
for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) {
for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) {
*oldChainPtr = hPtr->nextPtr;
-#if TCL_HASH_KEY_STORE_HASH
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash));
@@ -1071,26 +1054,6 @@ RebuildTable(
}
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
-#else
- void *key = Tcl_GetHashKey(tablePtr, hPtr);
-
- if (typePtr->hashKeyProc) {
- unsigned int hash;
-
- hash = typePtr->hashKeyProc(tablePtr, key);
- if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
- index = RANDOM_INDEX(tablePtr, hash);
- } else {
- index = hash & tablePtr->mask;
- }
- } else {
- index = RANDOM_INDEX(tablePtr, key);
- }
-
- hPtr->bucketPtr = &tablePtr->buckets[index];
- hPtr->nextPtr = *hPtr->bucketPtr;
- *hPtr->bucketPtr = hPtr;
-#endif
}
}
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 834f225..de65da5 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -16,7 +16,7 @@
*/
typedef struct AcceptCallback {
- char *script; /* Script to invoke. */
+ Tcl_Obj *script; /* Script to invoke. */
Tcl_Interp *interp; /* Interpreter in which to run it. */
} AcceptCallback;
@@ -37,8 +37,7 @@ static Tcl_ThreadDataKey dataKey;
*/
static void FinalizeIOCmdTSD(ClientData clientData);
-static void AcceptCallbackProc(ClientData callbackData,
- Tcl_Channel chan, char *address, int port);
+static Tcl_TcpAcceptProc AcceptCallbackProc;
static int ChanPendingObjCmd(ClientData unused,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -1373,15 +1372,22 @@ AcceptCallbackProc(
*/
if (acceptCallbackPtr->interp != NULL) {
- char portBuf[TCL_INTEGER_SPACE];
- char *script = acceptCallbackPtr->script;
Tcl_Interp *interp = acceptCallbackPtr->interp;
- int result;
+ Tcl_Obj *script, *objv[2];
+ int result = TCL_OK;
- Tcl_Preserve(script);
- Tcl_Preserve(interp);
+ objv[0] = acceptCallbackPtr->script;
+ objv[1] = Tcl_NewListObj(3, NULL);
+ Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(
+ Tcl_GetChannelName(chan), -1));
+ Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1));
+ Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewIntObj(port));
+
+ script = Tcl_ConcatObj(2, objv);
+ Tcl_IncrRefCount(script);
+ Tcl_DecrRefCount(objv[1]);
- TclFormatInt(portBuf, port);
+ Tcl_Preserve(interp);
Tcl_RegisterChannel(interp, chan);
/*
@@ -1391,8 +1397,9 @@ AcceptCallbackProc(
Tcl_RegisterChannel(NULL, chan);
- result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
- " ", address, " ", portBuf, NULL);
+ result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
+ Tcl_DecrRefCount(script);
+
if (result != TCL_OK) {
Tcl_BackgroundException(interp, result);
Tcl_UnregisterChannel(interp, chan);
@@ -1406,7 +1413,6 @@ AcceptCallbackProc(
Tcl_UnregisterChannel(NULL, chan);
Tcl_Release(interp);
- Tcl_Release(script);
} else {
/*
* The interpreter has been deleted, so there is no useful way to use
@@ -1450,7 +1456,7 @@ TcpServerCloseProc(
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
acceptCallbackPtr);
}
- Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC);
+ Tcl_DecrRefCount(acceptCallbackPtr->script);
ckfree(acceptCallbackPtr);
}
@@ -1485,7 +1491,8 @@ Tcl_SocketObjCmd(
SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
};
int optionIndex, a, server = 0, port, myport = 0, async = 0;
- const char *host, *script = NULL, *myaddr = NULL;
+ const char *host, *myaddr = NULL;
+ Tcl_Obj *script = NULL;
Tcl_Channel chan;
if (TclpHasSockets(interp) != TCL_OK) {
@@ -1548,7 +1555,7 @@ Tcl_SocketObjCmd(
"no argument given for -server option", -1));
return TCL_ERROR;
}
- script = TclGetString(objv[a]);
+ script = objv[a];
break;
default:
Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
@@ -1589,16 +1596,14 @@ Tcl_SocketObjCmd(
if (server) {
AcceptCallback *acceptCallbackPtr =
ckalloc(sizeof(AcceptCallback));
- unsigned len = strlen(script) + 1;
- char *copyScript = ckalloc(len);
- memcpy(copyScript, script, len);
- acceptCallbackPtr->script = copyScript;
+ Tcl_IncrRefCount(script);
+ acceptCallbackPtr->script = script;
acceptCallbackPtr->interp = interp;
chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
acceptCallbackPtr);
if (chan == NULL) {
- ckfree(copyScript);
+ Tcl_DecrRefCount(script);
ckfree(acceptCallbackPtr);
return TCL_ERROR;
}
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index c5b7d28..f61073b 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -197,7 +197,7 @@ TclCreateSocketAddress(
*/
if (interp != NULL) {
- family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0);
+ family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 0);
if (family != NULL) {
if (strcmp(family, "inet") == 0) {
hints.ai_family = AF_INET;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a6cc627..5ccd637 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -26,6 +26,19 @@
#undef ACCEPT_NAN
/*
+ * In Tcl 8.7, stop supporting special hacks for legacy Itcl 3.
+ * Itcl 4 doesn't need them. Itcl 3 can be updated to not need them
+ * using the Tcl(Init|Reset)RewriteEnsemble() routines in all Tcl 8.6+
+ * releases. Perhaps Tcl 8.7 will add even better public interfaces
+ * supporting all the re-invocation mechanisms extensions like Itcl 3
+ * need. As an absolute last resort, folks who must make Itcl 3 work
+ * unchanged with Tcl 8.7 can remove this line to regain the migration
+ * support. Tcl 9 will no longer offer even that option.
+ */
+
+#define AVOID_HACKS_FOR_ITCL 1
+
+/*
* Common include files needed by most of the Tcl source files are included
* here, so that system-dependent personalizations for the include files only
* have to be made in once place. This results in a few extra includes, but
@@ -3118,6 +3131,7 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
const char *trim, int numTrim);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
+MODULE_SCOPE int TclUtfCount(int ch);
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
@@ -4069,6 +4083,7 @@ MODULE_SCOPE void TclFreeAllocCache(void *);
MODULE_SCOPE void * TclpGetAllocCache(void);
MODULE_SCOPE void TclpSetAllocCache(void *);
MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex);
+MODULE_SCOPE void TclpInitAllocCache(void);
MODULE_SCOPE void TclpFreeAllocCache(void *);
/*
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 66ce1e0..c281d6d 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -336,7 +336,7 @@ Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
if (tclPreInitScript != NULL) {
- if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
+ if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) {
return TCL_ERROR;
}
}
@@ -382,7 +382,7 @@ Tcl_Init(
* alternate tclInit command before calling Tcl_Init().
*/
- return Tcl_Eval(interp,
+ return Tcl_EvalEx(interp,
"if {[namespace which -command tclInit] eq \"\"} {\n"
" proc tclInit {} {\n"
" global tcl_libPath tcl_library env tclDefaultLibrary\n"
@@ -444,7 +444,7 @@ Tcl_Init(
" error $msg\n"
" }\n"
"}\n"
-"tclInit");
+"tclInit", -1, 0);
}
/*
@@ -2368,7 +2368,7 @@ SlaveCreate(
SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, slavePtr);
- Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY);
/*
* Inherit the recursion limit.
@@ -3195,8 +3195,8 @@ Tcl_MakeSafe(
* Assume these functions all work. [Bug 2895741]
*/
- (void) Tcl_Eval(interp,
- "namespace eval ::tcl {namespace eval mathfunc {}}");
+ (void) Tcl_EvalEx(interp,
+ "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0);
(void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master,
"::tcl::mathfunc::min", 0, NULL);
(void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master,
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 927de7e..28f8fd8 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -112,7 +112,7 @@ typedef enum {
PROMPT_CONTINUE /* Print prompt for command continuation */
} PromptType;
-typedef struct InteractiveState {
+typedef struct {
Tcl_Channel input; /* The standard input channel from which lines
* are read. */
int tty; /* Non-zero means standard input is a
@@ -246,7 +246,7 @@ Tcl_SourceRCFile(
const char *fileName;
Tcl_Channel chan;
- fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
+ fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
const char *fullName;
@@ -266,14 +266,18 @@ Tcl_SourceRCFile(
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
if (c != NULL) {
+ Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1);
+
Tcl_Close(NULL, c);
- if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
+ Tcl_IncrRefCount(fullNameObj);
+ if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
+ Tcl_DecrRefCount(fullNameObj);
}
}
Tcl_DStringFree(&temp);
@@ -283,7 +287,7 @@ Tcl_SourceRCFile(
/*----------------------------------------------------------------------
*
- * Tcl_Main, Tcl_MainEx --
+ * Tcl_MainEx --
*
* Main program for tclsh and most other Tcl-based applications.
*
@@ -634,21 +638,6 @@ Tcl_MainEx(
Tcl_Exit(exitCode);
}
-
-#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE)
-#undef Tcl_Main
-extern DLLEXPORT void
-Tcl_Main(
- int argc, /* Number of arguments. */
- char **argv, /* Array of argument strings. */
- Tcl_AppInitProc *appInitProc)
- /* Application-specific initialization
- * function to call after most initialization
- * but before starting to execute commands. */
-{
- Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
-}
-#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */
#ifndef TCL_ASCII_MAIN
diff --git a/generic/tclOO.c b/generic/tclOO.c
index ec666ee..ef0c987 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -266,7 +266,7 @@ TclOOInit(
* to be fully provided.
*/
- if (Tcl_Eval(interp, initScript) != TCL_OK) {
+ if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
@@ -460,7 +460,7 @@ InitFoundation(
if (TclOODefineSlots(fPtr) != TCL_OK) {
return TCL_ERROR;
}
- return Tcl_Eval(interp, slotScript);
+ return Tcl_EvalEx(interp, slotScript, -1, 0);
}
/*
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 628c3a7..a45a392 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4176,7 +4176,7 @@ Tcl_GetCommandFromObj(
* had is invalid one way or another.
*/
- /* See [] why we cannot call SetCmdNameFromAny() directly here. */
+ /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */
if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
return NULL;
}
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 95abc45..5577e87 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -167,6 +167,8 @@ static int ParseTokens(const char *src, int numBytes, int mask,
int flags, Tcl_Parse *parsePtr);
static int ParseWhiteSpace(const char *src, int numBytes,
int *incompletePtr, char *typePtr);
+static int ParseAllWhiteSpace(const char *src, int numBytes,
+ int *incompletePtr);
/*
*----------------------------------------------------------------------
@@ -298,9 +300,43 @@ Tcl_ParseCommand(
*/
parsePtr->commandStart = src;
+ type = CHAR_TYPE(*src);
+ scanned = 1; /* Can't have missing whitepsace before first word. */
while (1) {
int expandWord = 0;
+ /* Are we at command termination? */
+
+ if ((numBytes == 0) || (type & terminators) != 0) {
+ parsePtr->term = src;
+ parsePtr->commandSize = src + (numBytes != 0)
+ - parsePtr->commandStart;
+ return TCL_OK;
+ }
+
+ /* Are we missing white space after previous word? */
+
+ if (scanned == 0) {
+ if (src[-1] == '"') {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-quote", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-brace", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
+ }
+ parsePtr->term = src;
+ error:
+ Tcl_FreeParse(parsePtr);
+ parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
+ return TCL_ERROR;
+ }
+
/*
* Create the token for the word.
*/
@@ -310,23 +346,6 @@ Tcl_ParseCommand(
tokenPtr = &parsePtr->tokenPtr[wordIndex];
tokenPtr->type = TCL_TOKEN_WORD;
- /*
- * Skip white space before the word. Also skip a backslash-newline
- * sequence: it should be treated just like white space.
- */
-
- scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type);
- src += scanned;
- numBytes -= scanned;
- if (numBytes == 0) {
- parsePtr->term = src;
- break;
- }
- if ((type & terminators) != 0) {
- parsePtr->term = src;
- src++;
- break;
- }
tokenPtr->start = src;
parsePtr->numTokens++;
parsePtr->numWords++;
@@ -546,52 +565,12 @@ Tcl_ParseCommand(
tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
}
- /*
- * Do two additional checks: (a) make sure we're really at the end of
- * a word (there might have been garbage left after a quoted or braced
- * word), and (b) check for the end of the command.
- */
+ /* Parse the whitespace between words. */
scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type);
- if (scanned) {
- src += scanned;
- numBytes -= scanned;
- continue;
- }
-
- if (numBytes == 0) {
- parsePtr->term = src;
- break;
- }
- if ((type & terminators) != 0) {
- parsePtr->term = src;
- src++;
- break;
- }
- if (src[-1] == '"') {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "extra characters after close-quote", -1));
- }
- parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
- } else {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "extra characters after close-brace", -1));
- }
- parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
- }
- parsePtr->term = src;
- goto error;
+ src += scanned;
+ numBytes -= scanned;
}
-
- parsePtr->commandSize = src - parsePtr->commandStart;
- return TCL_OK;
-
- error:
- Tcl_FreeParse(parsePtr);
- parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
- return TCL_ERROR;
}
/*
@@ -733,23 +712,32 @@ ParseWhiteSpace(
*----------------------------------------------------------------------
*/
-int
-TclParseAllWhiteSpace(
+static int
+ParseAllWhiteSpace(
const char *src, /* First character to parse. */
- int numBytes) /* Max number of byes to scan */
+ int numBytes, /* Max number of byes to scan */
+ int *incompletePtr) /* Set true if parse is incomplete. */
{
- int dummy;
char type;
const char *p = src;
do {
- int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type);
+ int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type);
p += scanned;
numBytes -= scanned;
} while (numBytes && (*p == '\n') && (p++, --numBytes));
return (p-src);
}
+
+int
+TclParseAllWhiteSpace(
+ const char *src, /* First character to parse. */
+ int numBytes) /* Max number of byes to scan */
+{
+ int dummy;
+ return ParseAllWhiteSpace(src, numBytes, &dummy);
+}
/*
*----------------------------------------------------------------------
@@ -1021,17 +1009,12 @@ ParseComment(
* command. */
{
register const char *p = src;
+ int incomplete = parsePtr->incomplete;
while (numBytes) {
- char type;
- int scanned;
-
- do {
- scanned = ParseWhiteSpace(p, numBytes,
- &parsePtr->incomplete, &type);
- p += scanned;
- numBytes -= scanned;
- } while (numBytes && (*p == '\n') && (p++,numBytes--));
+ int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete);
+ p += scanned;
+ numBytes -= scanned;
if ((numBytes == 0) || (*p != '#')) {
break;
@@ -1040,35 +1023,28 @@ ParseComment(
parsePtr->commentStart = p;
}
+ p++;
+ numBytes--;
while (numBytes) {
+ if (*p == '\n') {
+ p++;
+ numBytes--;
+ break;
+ }
if (*p == '\\') {
- scanned = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete,
- &type);
- if (scanned) {
- p += scanned;
- numBytes -= scanned;
- } else {
- /*
- * General backslash substitution in comments isn't part
- * of the formal spec, but test parse-15.47 and history
- * indicate that it has been the de facto rule. Don't
- * change it now.
- */
-
- TclParseBackslash(p, numBytes, &scanned, NULL);
- p += scanned;
- numBytes -= scanned;
- }
- } else {
p++;
numBytes--;
- if (p[-1] == '\n') {
+ if (numBytes == 0) {
break;
}
}
+ incomplete = (*p == '\n');
+ p++;
+ numBytes--;
}
parsePtr->commentSize = p - parsePtr->commentStart;
}
+ parsePtr->incomplete = incomplete;
return (p - src);
}
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index f6e8b20..86777a8 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -1895,7 +1895,7 @@ Tcl_PkgInitStubsCheck(
{
const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0);
- if (exact && actualVersion) {
+ if ((exact&1) && actualVersion) {
const char *p = version;
int count = 0;
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 11a57e9..b480735 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -39,15 +39,6 @@
#include "tclStringRep.h"
/*
- * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5.
- * This is an escape hatch in case the changes have some unexpected unwelcome
- * impact on performance. If things go well, this mechanism can go away when
- * post-8.6 development begins.
- */
-
-#define COMPAT 0
-
-/*
* Prototypes for functions defined later in this file:
*/
@@ -445,18 +436,6 @@ Tcl_GetCharLength(
if (numChars == -1) {
TclNumUtfChars(numChars, objPtr->bytes, objPtr->length);
stringPtr->numChars = numChars;
-
-#if COMPAT
- if (numChars < objPtr->length) {
- /*
- * Since we've just computed the number of chars, and not all UTF
- * chars are 1-byte long, go ahead and populate the unicode
- * string.
- */
-
- FillUnicodeRep(objPtr);
- }
-#endif
}
return numChars;
}
@@ -1173,11 +1152,7 @@ Tcl_AppendUnicodeToObj(
* objPtr's string rep.
*/
- if (stringPtr->hasUnicode
-#if COMPAT
- && stringPtr->numChars > 0
-#endif
- ) {
+ if (stringPtr->hasUnicode) {
AppendUnicodeToUnicodeRep(objPtr, unicode, length);
} else {
AppendUnicodeToUtfRep(objPtr, unicode, length);
@@ -1281,11 +1256,7 @@ Tcl_AppendObjToObj(
* appendObjPtr and append it.
*/
- if (stringPtr->hasUnicode
-#if COMPAT
- && stringPtr->numChars > 0
-#endif
- ) {
+ if (stringPtr->hasUnicode) {
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
@@ -1318,11 +1289,7 @@ Tcl_AppendObjToObj(
AppendUtfToUtfRep(objPtr, bytes, length);
- if (numChars >= 0 && appendNumChars >= 0
-#if COMPAT
- && appendNumChars == length
-#endif
- ) {
+ if (numChars >= 0 && appendNumChars >= 0) {
stringPtr->numChars = numChars + appendNumChars;
}
}
@@ -1446,14 +1413,6 @@ AppendUnicodeToUtfRep(
if (stringPtr->numChars != -1) {
stringPtr->numChars += numChars;
}
-
-#if COMPAT
- /*
- * Invalidate the unicode rep.
- */
-
- stringPtr->hasUnicode = 0;
-#endif
}
/*
@@ -2871,7 +2830,6 @@ DupStringInternalRep(
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
-#if COMPAT==0
if (srcStringPtr->numChars == -1) {
/*
* The String struct in the source value holds zero useful data. Don't
@@ -2914,41 +2872,6 @@ DupStringInternalRep(
*/
copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0;
-#else /* COMPAT!=0 */
- /*
- * If the src obj is a string of 1-byte Utf chars, then copy the string
- * rep of the source object and create an "empty" Unicode internal rep for
- * the new object. Otherwise, copy Unicode internal rep, and invalidate
- * the string rep of the new object.
- */
-
- if (srcStringPtr->hasUnicode && srcStringPtr->numChars > 0) {
- /*
- * Copy the full allocation for the Unicode buffer.
- */
-
- copyStringPtr = stringAlloc(srcStringPtr->maxChars);
- copyStringPtr->maxChars = srcStringPtr->maxChars;
- memcpy(copyStringPtr->unicode, srcStringPtr->unicode,
- srcStringPtr->numChars * sizeof(Tcl_UniChar));
- copyStringPtr->unicode[srcStringPtr->numChars] = 0;
- copyStringPtr->allocated = 0;
- } else {
- copyStringPtr = stringAlloc(0);
- copyStringPtr->unicode[0] = 0;
- copyStringPtr->maxChars = 0;
-
- /*
- * Tricky point: the string value was copied by generic object
- * management code, so it doesn't contain any extra bytes that might
- * exist in the source object.
- */
-
- copyStringPtr->allocated = copyPtr->length;
- }
- copyStringPtr->numChars = srcStringPtr->numChars;
- copyStringPtr->hasUnicode = srcStringPtr->hasUnicode;
-#endif /* COMPAT==0 */
SET_STRING(copyPtr, copyStringPtr);
copyPtr->typePtr = &tclStringType;
@@ -3044,7 +2967,7 @@ ExtendStringRepWithUnicode(
*/
int i, origLength, size = 0;
- char *dst, buf[TCL_UTF_MAX];
+ char *dst;
String *stringPtr = GET_STRING(objPtr);
if (numChars < 0) {
@@ -3070,7 +2993,7 @@ ExtendStringRepWithUnicode(
}
for (i = 0; i < numChars && size >= 0; i++) {
- size += Tcl_UniCharToUtf((int) unicode[i], buf);
+ size += TclUtfCount(unicode[i]);
}
if (size < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h
index 227e6bc..db6f7e4 100644
--- a/generic/tclStringRep.h
+++ b/generic/tclStringRep.h
@@ -46,7 +46,7 @@
* tcl.h, but do not do that unless you are sure what you're doing!
*/
-typedef struct String {
+typedef struct {
int numChars; /* The number of chars in the string. -1 means
* this value has not been calculated. >= 0
* means that there is a valid Unicode rep, or
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index 859cbf9..afabdca 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -24,13 +24,10 @@ const TclIntStubs *tclIntStubsPtr = NULL;
const TclIntPlatStubs *tclIntPlatStubsPtr = NULL;
/*
- * Use our own isDigit to avoid linking to libc on windows
+ * Use our own ISDIGIT to avoid linking to libc on windows
*/
-static int isDigit(const int c)
-{
- return (c >= '0' && c <= '9');
-}
+#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9)
/*
*----------------------------------------------------------------------
@@ -54,7 +51,8 @@ MODULE_SCOPE const char *
Tcl_InitStubs(
Tcl_Interp *interp,
const char *version,
- int exact)
+ int exact,
+ int magic)
{
Interp *iPtr = (Interp *) interp;
const char *actualVersion = NULL;
@@ -67,8 +65,8 @@ Tcl_InitStubs(
* times. [Bug 615304]
*/
- if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) {
- iPtr->result = "interpreter uses an incompatible stubs mechanism";
+ if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) {
+ iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism";
iPtr->freeProc = TCL_STATIC;
return NULL;
}
@@ -77,12 +75,12 @@ Tcl_InitStubs(
if (actualVersion == NULL) {
return NULL;
}
- if (exact) {
+ if (exact&1) {
const char *p = version;
int count = 0;
while (*p) {
- count += !isDigit(*p++);
+ count += !ISDIGIT(*p++);
}
if (count == 1) {
const char *q = actualVersion;
@@ -91,7 +89,7 @@ Tcl_InitStubs(
while (*p && (*p == *q)) {
p++; q++;
}
- if (*p || isDigit(*q)) {
+ if (*p || ISDIGIT(*q)) {
/* Construct error message */
stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
return NULL;
diff --git a/generic/tclTest.c b/generic/tclTest.c
index e33d263..d3da641 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -42,16 +42,8 @@
* Declare external functions used in Windows tests.
*/
-/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Tcltest_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
- */
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-EXTERN int Tcltest_Init(Tcl_Interp *interp);
-EXTERN int Tcltest_SafeInit(Tcl_Interp *interp);
+DLLEXPORT int Tcltest_Init(Tcl_Interp *interp);
+DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp);
/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
@@ -323,6 +315,9 @@ static int TestparsevarObjCmd(ClientData dummy,
static int TestparsevarnameObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestpreferstableObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestregexpObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -652,6 +647,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd,
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
@@ -1288,7 +1285,7 @@ TestcmdtraceCmd(
cmdTrace = Tcl_CreateObjTrace(interp, 50000,
TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc,
(ClientData) &deleteCalled, ObjTraceDeleteProc);
- result = Tcl_Eval(interp, argv[2]);
+ result = Tcl_EvalEx(interp, argv[2], -1, 0);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC);
@@ -1302,7 +1299,7 @@ TestcmdtraceCmd(
Tcl_DStringInit(&buffer);
t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer);
t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
- result = Tcl_Eval(interp, argv[2]);
+ result = Tcl_EvalEx(interp, argv[2], -1, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1631,7 +1628,7 @@ DelDeleteProc(
{
DelCmd *dPtr = clientData;
- Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
+ Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0);
Tcl_ResetResult(dPtr->interp);
ckfree(dPtr->deleteCmd);
ckfree(dPtr);
@@ -3793,6 +3790,36 @@ TestparsevarnameObjCmd(
/*
*----------------------------------------------------------------------
*
+ * TestpreferstableObjCmd --
+ *
+ * This procedure implements the "testpreferstable" command. It is
+ * used for being able to test the "package" command even when the
+ * environment variable TCL_PKG_PREFER_LATEST is set in your environment.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestpreferstableObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ iPtr->packagePrefer = PKG_PREFER_STABLE;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestregexpObjCmd --
*
* This procedure implements the "testregexp" command. It is used to give
@@ -3936,7 +3963,7 @@ TestregexpObjCmd(
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, -1, &start, &end);
sprintf(resinfo, "%d %d", start, end-1);
- value = Tcl_SetVar(interp, varName, resinfo, 0);
+ value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
@@ -3950,7 +3977,7 @@ TestregexpObjCmd(
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
sprintf(resinfo, "%ld", info.extendStart);
- value = Tcl_SetVar(interp, varName, resinfo, 0);
+ value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
@@ -4293,7 +4320,7 @@ StaticInitProc(
Tcl_Interp *interp) /* Interpreter in which package is supposedly
* being loaded. */
{
- Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY);
return TCL_OK;
}
@@ -4377,7 +4404,7 @@ TestupvarCmd(
} else if (strcmp(argv[4], "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
- return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags);
+ return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags);
} else {
if (strcmp(argv[5], "global") == 0) {
flags = TCL_GLOBAL_ONLY;
@@ -4871,10 +4898,10 @@ GetTimesObjCmd(
timePer/100000);
/* Tcl_SetVar 100000 times */
- fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n");
+ fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
- s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG);
+ s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
@@ -4888,7 +4915,7 @@ GetTimesObjCmd(
fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
- s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG);
+ s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
@@ -5158,7 +5185,7 @@ TestsaveresultCmd(
if (((enum options) index) == RESULT_OBJECT) {
result = Tcl_EvalObjEx(interp, objv[2], 0);
} else {
- result = Tcl_Eval(interp, Tcl_GetString(objv[2]));
+ result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0);
}
if (discard) {
@@ -6261,7 +6288,7 @@ TestReport(
savedResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(savedResult);
Tcl_SetObjResult(interp, Tcl_NewObj());
- Tcl_Eval(interp, Tcl_DStringValue(&ds));
+ Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0);
Tcl_DStringFree(&ds);
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, savedResult);
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 9c66313..1a05f80 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -657,7 +657,7 @@ ThreadErrorProc(
sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
- errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
+ errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_WriteChars(errChannel, "Error from thread ", -1);
@@ -1032,8 +1032,8 @@ ThreadEventProc(
code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL);
Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
if (code != TCL_OK) {
- errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
- errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
+ errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
+ errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index c10986a..c83b5f5 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -91,7 +91,7 @@ typedef struct IdleHandler {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
TimerHandler *firstTimerHandlerPtr; /* First event in queue. */
int lastTimerId; /* Timer identifier of most recently created
* timer. */
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 4e74c54..33e62b2 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -143,7 +143,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1,
* trace procs
*/
-typedef struct StringTraceData {
+typedef struct {
ClientData clientData; /* Client data from Tcl_CreateTrace */
Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */
} StringTraceData;
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index b878149..6c4cb7f 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -84,17 +84,11 @@ static const unsigned char totalBytes[256] = {
1,1,1,1
#endif
};
-
-/*
- * Functions used only in this module.
- */
-
-static int UtfCount(int ch);
/*
*---------------------------------------------------------------------------
*
- * UtfCount --
+ * TclUtfCount --
*
* Find the number of bytes in the Utf character "ch".
*
@@ -107,8 +101,8 @@ static int UtfCount(int ch);
*---------------------------------------------------------------------------
*/
-INLINE static int
-UtfCount(
+int
+TclUtfCount(
int ch) /* The Tcl_UniChar whose size is returned. */
{
if ((ch > 0) && (ch < UNICODE_SELF)) {
@@ -143,7 +137,7 @@ UtfCount(
*---------------------------------------------------------------------------
*/
-INLINE int
+int
Tcl_UniCharToUtf(
int ch, /* The Tcl_UniChar to be stored in the
* buffer. */
@@ -829,7 +823,7 @@ Tcl_UtfToUpper(
* char to dst if its size is <= the original char.
*/
- if (bytes < UtfCount(upChar)) {
+ if (bytes < TclUtfCount(upChar)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
@@ -882,7 +876,7 @@ Tcl_UtfToLower(
* char to dst if its size is <= the original char.
*/
- if (bytes < UtfCount(lowChar)) {
+ if (bytes < TclUtfCount(lowChar)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
@@ -932,7 +926,7 @@ Tcl_UtfToTitle(
bytes = TclUtfToUniChar(src, &ch);
titleChar = Tcl_UniCharToTitle(ch);
- if (bytes < UtfCount(titleChar)) {
+ if (bytes < TclUtfCount(titleChar)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
@@ -944,7 +938,7 @@ Tcl_UtfToTitle(
bytes = TclUtfToUniChar(src, &ch);
lowChar = Tcl_UniCharToLower(ch);
- if (bytes < UtfCount(lowChar)) {
+ if (bytes < TclUtfCount(lowChar)) {
memcpy(dst, src, (size_t) bytes);
dst += bytes;
} else {
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 51e2482..dc7fa20 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -202,14 +202,9 @@ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp,
static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_FreeInternalRepProc FreeLocalVarName;
-static Tcl_UpdateStringProc PanicOnUpdateVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
static Tcl_DupInternalRepProc DupParsedVarName;
-static Tcl_UpdateStringProc UpdateParsedVarName;
-
-static Tcl_UpdateStringProc PanicOnUpdateVarName;
-static Tcl_SetFromAnyProc PanicOnSetVarName;
/*
* Types of Tcl_Objs used to cache variable lookups.
@@ -232,12 +227,12 @@ static Tcl_SetFromAnyProc PanicOnSetVarName;
static const Tcl_ObjType localVarNameType = {
"localVarName",
- FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName
+ FreeLocalVarName, DupLocalVarName, NULL, NULL
};
static const Tcl_ObjType tclParsedVarNameType = {
"parsedVarName",
- FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName
+ FreeParsedVarName, DupParsedVarName, NULL, NULL
};
/*
@@ -536,7 +531,6 @@ TclObjLookupVarEx(
const char *errMsg = NULL;
CallFrame *varFramePtr = iPtr->varFramePtr;
const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL;
- char *newPart2 = NULL;
*arrayPtrPtr = NULL;
if (typePtr == &localVarNameType) {
@@ -583,9 +577,7 @@ TclObjLookupVarEx(
}
return NULL;
}
- part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2;
- if (newPart2) {
- part2Ptr = Tcl_NewStringObj(newPart2, -1);
+ if ((part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2)) {
if (createPart2) {
Tcl_IncrRefCount(part2Ptr);
}
@@ -629,11 +621,7 @@ TclObjLookupVarEx(
len2 = len1 - i - 2;
len1 = i;
- newPart2 = ckalloc(len2 + 1);
- memcpy(newPart2, part2, (unsigned) len2);
- *(newPart2+len2) = '\0';
- part2 = newPart2;
- part2Ptr = Tcl_NewStringObj(newPart2, -1);
+ part2Ptr = Tcl_NewStringObj(part2, len2);
if (createPart2) {
Tcl_IncrRefCount(part2Ptr);
}
@@ -658,7 +646,8 @@ TclObjLookupVarEx(
Tcl_IncrRefCount(part1Ptr);
objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr;
- objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2;
+ Tcl_IncrRefCount(part2Ptr);
+ objPtr->internalRep.twoPtrValue.ptr2 = part2Ptr;
typePtr = part1Ptr->typePtr;
part1 = TclGetString(part1Ptr);
@@ -683,9 +672,6 @@ TclObjLookupVarEx(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
TclGetString(part1Ptr), NULL);
}
- if (newPart2) {
- Tcl_DecrRefCount(part2Ptr);
- }
return NULL;
}
@@ -734,9 +720,6 @@ TclObjLookupVarEx(
*arrayPtrPtr = varPtr;
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg,
createPart1, createPart2, varPtr, -1);
- if (newPart2) {
- Tcl_DecrRefCount(part2Ptr);
- }
}
return varPtr;
}
@@ -5519,28 +5502,6 @@ TclObjVarErrMsg(
*/
/*
- * Panic functions that should never be called in normal operation.
- */
-
-static void
-PanicOnUpdateVarName(
- Tcl_Obj *objPtr)
-{
- Tcl_Panic("%s of type %s should not be called", "updateStringProc",
- objPtr->typePtr->name);
-}
-
-static int
-PanicOnSetVarName(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr)
-{
- Tcl_Panic("%s of type %s should not be called", "setFromAnyProc",
- objPtr->typePtr->name);
- return TCL_ERROR;
-}
-
-/*
* localVarName -
*
* INTERNALREP DEFINITION:
@@ -5593,11 +5554,11 @@ FreeParsedVarName(
Tcl_Obj *objPtr)
{
register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
- register char *elem = objPtr->internalRep.twoPtrValue.ptr2;
+ register Tcl_Obj *elem = objPtr->internalRep.twoPtrValue.ptr2;
if (arrayPtr != NULL) {
TclDecrRefCount(arrayPtr);
- ckfree(elem);
+ TclDecrRefCount(elem);
}
objPtr->typePtr = NULL;
}
@@ -5608,58 +5569,17 @@ DupParsedVarName(
Tcl_Obj *dupPtr)
{
register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- register char *elem = srcPtr->internalRep.twoPtrValue.ptr2;
- char *elemCopy;
- unsigned elemLen;
+ register Tcl_Obj *elem = srcPtr->internalRep.twoPtrValue.ptr2;
if (arrayPtr != NULL) {
Tcl_IncrRefCount(arrayPtr);
- elemLen = strlen(elem);
- elemCopy = ckalloc(elemLen + 1);
- memcpy(elemCopy, elem, elemLen);
- *(elemCopy + elemLen) = '\0';
- elem = elemCopy;
+ Tcl_IncrRefCount(elem);
}
dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr;
dupPtr->internalRep.twoPtrValue.ptr2 = elem;
dupPtr->typePtr = &tclParsedVarNameType;
}
-
-static void
-UpdateParsedVarName(
- Tcl_Obj *objPtr)
-{
- Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
- char *part2 = objPtr->internalRep.twoPtrValue.ptr2;
- const char *part1;
- char *p;
- int len1, len2, totalLen;
-
- if (arrayPtr == NULL) {
- /*
- * This is a parsed scalar name: what is it doing here?
- */
-
- Tcl_Panic("scalar parsedVarName without a string rep");
- }
-
- part1 = TclGetStringFromObj(arrayPtr, &len1);
- len2 = strlen(part2);
-
- totalLen = len1 + len2 + 2;
- p = ckalloc(totalLen + 1);
- objPtr->bytes = p;
- objPtr->length = totalLen;
-
- memcpy(p, part1, (unsigned) len1);
- p += len1;
- *p++ = '(';
- memcpy(p, part2, (unsigned) len2);
- p += len2;
- *p++ = ')';
- *p = '\0';
-}
/*
*----------------------------------------------------------------------
generated by cgit v0.12 at 2024-09-29 20:50:47 (GMT)