summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2019-05-17 07:31:47 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2019-05-17 07:31:47 (GMT)
commitc54b6957b8f0577a8d2789b9cc88a04a7da7a478 (patch)
treea88c9c80571094587464060f1a831a268d8e8302 /generic
parent0f34d49b76e87e5f454a9b468e981bc71f43907c (diff)
parent503da2614f2490195b2bd436c44cc52f3678becd (diff)
downloadtcl-c54b6957b8f0577a8d2789b9cc88a04a7da7a478.zip
tcl-c54b6957b8f0577a8d2789b9cc88a04a7da7a478.tar.gz
tcl-c54b6957b8f0577a8d2789b9cc88a04a7da7a478.tar.bz2
merge core-8-branch
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c187
-rw-r--r--generic/tclBinary.c5
-rw-r--r--generic/tclCmdIL.c40
-rw-r--r--generic/tclCompCmdsGR.c48
-rw-r--r--generic/tclCompCmdsSZ.c36
-rw-r--r--generic/tclDecls.h2
-rw-r--r--generic/tclIO.c40
-rw-r--r--generic/tclIORChan.c8
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclLink.c23
-rw-r--r--generic/tclNamesp.c7
-rw-r--r--generic/tclOO.c89
-rw-r--r--generic/tclOOCall.c17
-rw-r--r--generic/tclOODefineCmds.c76
-rw-r--r--generic/tclResult.c6
-rw-r--r--generic/tclStrToD.c30
-rw-r--r--generic/tclStringObj.c10
-rw-r--r--generic/tclStubInit.c2
-rw-r--r--generic/tclTest.c15
-rw-r--r--generic/tclTimer.c26
-rw-r--r--generic/tclTomMath.h78
-rw-r--r--generic/tclTomMathDecls.h7
-rw-r--r--generic/tclZipfs.c23
23 files changed, 505 insertions, 273 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 4db275d..ae7d7ff 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -173,6 +173,7 @@ static Tcl_NRPostProc Dispatch;
static Tcl_ObjCmdProc NRCoroInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
+static Tcl_ObjCmdProc CoroTypeObjCmd;
MODULE_SCOPE const TclStubs tclStubs;
@@ -974,8 +975,11 @@ Tcl_CreateInterp(void)
TclNRAssembleObjCmd, NULL, NULL);
cmdPtr->compileProc = &TclCompileAssembleCmd;
+ /* Coroutine monkeybusiness */
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
NRCoroInjectObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
+ CoroTypeObjCmd, NULL, NULL);
/* Export unsupported commands */
nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
@@ -2378,14 +2382,16 @@ Tcl_CreateCommand(
break;
}
- /* An existing command conflicts. Try to delete it.. */
+ /*
+ * An existing command conflicts. Try to delete it...
+ */
+
cmdPtr = Tcl_GetHashValue(hPtr);
/*
- * Be careful to preserve
- * any existing import links so we can restore them down below. That
- * way, you can redefine a command and its import status will remain
- * intact.
+ * Be careful to preserve any existing import links so we can restore
+ * them down below. That way, you can redefine a command and its
+ * import status will remain intact.
*/
cmdPtr->refCount++;
@@ -2405,16 +2411,15 @@ Tcl_CreateCommand(
if (!isNew) {
/*
- * If the deletion callback recreated the command, just throw away
- * the new command (if we try to delete it again, we could get
- * stuck in an infinite loop).
+ * If the deletion callback recreated the command, just throw away the
+ * new command (if we try to delete it again, we could get stuck in an
+ * infinite loop).
*/
ckfree(Tcl_GetHashValue(hPtr));
}
if (!deleted) {
-
/*
* Command resolvers (per-interp, per-namespace) might have resolved
* to a command for the given namespace scope with this command not
@@ -2597,17 +2602,17 @@ TclCreateObjCommandInNs(
}
/*
- * An existing command conflicts. Try to delete it.
+ * An existing command conflicts. Try to delete it...
*/
cmdPtr = Tcl_GetHashValue(hPtr);
/*
- * [***] This is wrong. See Tcl Bug a16752c252. However, this buggy
- * behavior is kept under particular circumstances to accommodate
- * deployed binaries of the "tclcompiler" program
- * http://sourceforge.net/projects/tclpro/
- * that crash if the bug is fixed.
+ * [***] This is wrong. See Tcl Bug a16752c252.
+ * However, this buggy behavior is kept under particular circumstances
+ * to accommodate deployed binaries of the "tclcompiler" program
+ * <http://sourceforge.net/projects/tclpro/> that crash if the bug is
+ * fixed.
*/
if (cmdPtr->objProc == TclInvokeStringCommand
@@ -4607,15 +4612,22 @@ EvalObjvCore(
reresolve:
assert(cmdPtr == NULL);
if (preCmdPtr) {
- /* Caller gave it to us */
+ /*
+ * Caller gave it to us.
+ */
+
if (!(preCmdPtr->flags & CMD_IS_DELETED)) {
- /* So long as it exists, use it. */
+ /*
+ * So long as it exists, use it.
+ */
+
cmdPtr = preCmdPtr;
} else if (flags & TCL_EVAL_NORESOLVE) {
/*
- * When it's been deleted, and we're told not to attempt
- * resolving it ourselves, all we can do is raise an error.
+ * When it's been deleted, and we're told not to attempt resolving
+ * it ourselves, all we can do is raise an error.
*/
+
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to invoke a deleted command"));
Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
@@ -4631,14 +4643,12 @@ EvalObjvCore(
if (enterTracesDone || iPtr->tracePtr
|| (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
-
Tcl_Obj *commandPtr = TclGetSourceFromFrame(
flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL,
objc, objv);
- Tcl_IncrRefCount(commandPtr);
+ Tcl_IncrRefCount(commandPtr);
if (!enterTracesDone) {
-
int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
objc, objv);
@@ -4646,10 +4656,10 @@ EvalObjvCore(
* Send any exception from enter traces back as an exception
* raised by the traced command.
* TODO: Is this a bug? Letting an execution trace BREAK or
- * CONTINUE or RETURN in the place of the traced command?
- * Would either converting all exceptions to TCL_ERROR, or
- * just swallowing them be better? (Swallowing them has the
- * problem of permanently hiding program errors.)
+ * CONTINUE or RETURN in the place of the traced command? Would
+ * either converting all exceptions to TCL_ERROR, or just
+ * swallowing them be better? (Swallowing them has the problem of
+ * permanently hiding program errors.)
*/
if (code != TCL_OK) {
@@ -4658,9 +4668,8 @@ EvalObjvCore(
}
/*
- * If the enter traces made the resolved cmdPtr unusable, go
- * back and resolve again, but next time don't run enter
- * traces again.
+ * If the enter traces made the resolved cmdPtr unusable, go back
+ * and resolve again, but next time don't run enter traces again.
*/
if (cmdPtr == NULL) {
@@ -4671,9 +4680,9 @@ EvalObjvCore(
}
/*
- * Schedule leave traces. Raise the refCount on the resolved
- * cmdPtr, so that when it passes to the leave traces we know
- * it's still valid.
+ * Schedule leave traces. Raise the refCount on the resolved cmdPtr,
+ * so that when it passes to the leave traces we know it's still
+ * valid.
*/
cmdPtr->refCount++;
@@ -4743,8 +4752,6 @@ TclNRRunCallbacks(
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Interp *iPtr = (Interp *) interp;
#endif /* !defined(TCL_NO_DEPRECATED) */
- NRE_callback *callbackPtr;
- Tcl_NRPostProc *procPtr;
/*
* If the interpreter has a non-empty string result, the result object is
@@ -4762,11 +4769,14 @@ TclNRRunCallbacks(
}
#endif /* !defined(TCL_NO_DEPRECATED) */
- /* This is the trampoline. */
+ /*
+ * This is the trampoline.
+ */
while (TOP_CB(interp) != rootPtr) {
- callbackPtr = TOP_CB(interp);
- procPtr = callbackPtr->procPtr;
+ NRE_callback *callbackPtr = TOP_CB(interp);
+ Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
+
TOP_CB(interp) = callbackPtr->nextPtr;
result = procPtr(callbackPtr->data, interp, result);
TCLNR_FREE(interp, callbackPtr);
@@ -6974,14 +6984,17 @@ TclNRInvoke(
}
cmdPtr = Tcl_GetHashValue(hPtr);
- /* Avoid the exception-handling brain damage when numLevels == 0 . */
+ /*
+ * Avoid the exception-handling brain damage when numLevels == 0
+ */
+
iPtr->numLevels++;
Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);
/*
* Normal command resolution of objv[0] isn't going to find cmdPtr.
- * That's the whole point of **hidden** commands. So tell the
- * Eval core machinery not to even try (and risk finding something wrong).
+ * That's the whole point of **hidden** commands. So tell the Eval core
+ * machinery not to even try (and risk finding something wrong).
*/
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
@@ -8375,13 +8388,21 @@ TclDTraceInfo(
Tcl_DictObjGet(NULL, info, *k++, &val);
args[i] = val ? TclGetString(val) : NULL;
}
- /* no "proc" -> use "lambda" */
+
+ /*
+ * no "proc" -> use "lambda"
+ */
+
if (!args[2]) {
Tcl_DictObjGet(NULL, info, *k, &val);
args[2] = val ? TclGetString(val) : NULL;
}
k++;
- /* no "class" -> use "object" */
+
+ /*
+ * no "class" -> use "object"
+ */
+
if (!args[5]) {
Tcl_DictObjGet(NULL, info, *k, &val);
args[5] = val ? TclGetString(val) : NULL;
@@ -8735,8 +8756,10 @@ TclNRTailcallObjCmd(
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
- /* The tailcall data is in a Tcl list: the first element is the
- * namespace, the rest the command to be tailcalled. */
+ /*
+ * The tailcall data is in a Tcl list: the first element is the
+ * namespace, the rest the command to be tailcalled.
+ */
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
listPtr = Tcl_NewListObj(objc, objv);
@@ -9187,6 +9210,75 @@ TclNREvalList(
/*
*----------------------------------------------------------------------
*
+ * CoroTypeObjCmd --
+ *
+ * Implementation of [::tcl::unsupported::corotype] command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CoroTypeObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Command *cmdPtr;
+ CoroutineData *corPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "coroName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the coroutine.
+ */
+
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
+ if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only get coroutine type of a coroutine", -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
+ TclGetString(objv[1]), NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * An active coroutine is "active". Can't tell what it might do in the
+ * future.
+ */
+
+ corPtr = cmdPtr->objClientData;
+ if (!COR_IS_SUSPENDED(corPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
+ return TCL_OK;
+ }
+
+ /*
+ * Inactive coroutines are classified by the (effective) command used to
+ * suspend them, which matters when you're injecting a probe.
+ */
+
+ switch (corPtr->nargs) {
+ case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1));
+ return TCL_OK;
+ case COROUTINE_ARGUMENTS_ARBITRARY:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1));
+ return TCL_OK;
+ default:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unknown coroutine type", -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL);
+ return TCL_ERROR;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* NRCoroInjectObjCmd --
*
* Implementation of [::tcl::unsupported::inject] command.
@@ -9417,9 +9509,12 @@ TclNRCoroutineObjCmd(
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
NULL, NULL, NULL);
- /* ensure that the command is looked up in the correct namespace */
+ /*
+ * Ensure that the command is looked up in the correct namespace.
+ */
+
iPtr->lookupNsPtr = lookupNsPtr;
- Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
+ Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0);
iPtr->numLevels--;
SAVE_CONTEXT(corPtr->running);
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 1f78d18..246c371 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -771,7 +771,10 @@ TclAppendBytesToByteArray(
"TclAppendBytesToByteArray");
}
if (len == 0) {
- /* Append zero bytes is a no-op. */
+ /*
+ * Append zero bytes is a no-op.
+ */
+
return;
}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index ef7a42c..c11534e 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -56,7 +56,7 @@ typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t);
* The following structure is used to pass this information.
*/
-typedef struct SortInfo {
+typedef struct {
int isIncreasing; /* Nonzero means sort in increasing order. */
int sortMode; /* The sort mode. One of SORTMODE_* values
* defined below. */
@@ -566,7 +566,7 @@ InfoBodyCmd(
* the object do not invalidate the internal rep.
*/
- bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes);
+ bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes);
Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
return TCL_OK;
}
@@ -1047,7 +1047,7 @@ InfoErrorStackCmd(
target = interp;
if (objc == 2) {
- target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
+ target = Tcl_GetSlave(interp, TclGetString(objv[1]));
if (target == NULL) {
return TCL_ERROR;
}
@@ -2155,7 +2155,7 @@ InfoCmdTypeCmd(
Tcl_WrongNumArgs(interp, 1, objv, "commandName");
return TCL_ERROR;
}
- command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL,
+ command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL,
TCL_LEAVE_ERR_MSG);
if (command == NULL) {
return TCL_ERROR;
@@ -2231,7 +2231,7 @@ Tcl_JoinObjCmd(
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
- (void) Tcl_GetStringFromObj(joinObjPtr, &length);
+ (void) TclGetStringFromObj(joinObjPtr, &length);
if (length == 0) {
resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
} else {
@@ -2721,15 +2721,13 @@ Tcl_LrangeObjCmd(
*----------------------------------------------------------------------
*/
-typedef int list_index_t;
-
static int
LremoveIndexCompare(
const void *el1Ptr,
const void *el2Ptr)
{
- list_index_t idx1 = *((const list_index_t *) el1Ptr);
- list_index_t idx2 = *((const list_index_t *) el2Ptr);
+ int idx1 = *((const int *) el1Ptr);
+ int idx2 = *((const int *) el2Ptr);
/*
* This will put the larger element first.
@@ -2746,7 +2744,7 @@ Tcl_LremoveObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, idxc;
- list_index_t listLen, *idxv, prevIdx, first, num;
+ int listLen, *idxv, prevIdx, first, num;
Tcl_Obj *listObj;
/*
@@ -2768,7 +2766,7 @@ Tcl_LremoveObjCmd(
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
- idxv = ckalloc((objc - 2) * sizeof(list_index_t));
+ idxv = ckalloc((objc - 2) * sizeof(int));
for (i = 2; i < objc; i++) {
if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
&idxv[i - 2]) != TCL_OK) {
@@ -2783,7 +2781,7 @@ Tcl_LremoveObjCmd(
*/
if (idxc > 1) {
- qsort(idxv, idxc, sizeof(list_index_t), LremoveIndexCompare);
+ qsort(idxv, idxc, sizeof(int), LremoveIndexCompare);
}
/*
@@ -2796,7 +2794,7 @@ Tcl_LremoveObjCmd(
num = 0;
first = listLen;
for (i = 0, prevIdx = -1 ; i < idxc ; i++) {
- list_index_t idx = idxv[i];
+ int idx = idxv[i];
/*
* Repeated index and sanity check.
@@ -3003,7 +3001,7 @@ Tcl_LreplaceObjCmd(
return result;
}
- if (first < 0) {
+ if (first == TCL_INDEX_NONE) {
first = 0;
}
if (first > listLen) {
@@ -3382,10 +3380,10 @@ Tcl_LsearchObjCmd(
TCL_INDEX_NONE, &encoded) != TCL_OK) {
result = TCL_ERROR;
}
- if (encoded == TCL_INDEX_NONE) {
+ if (encoded == (int)TCL_INDEX_NONE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" cannot select an element "
- "from any list", Tcl_GetString(indices[j])));
+ "from any list", TclGetString(indices[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
result = TCL_ERROR;
@@ -3515,8 +3513,8 @@ Tcl_LsearchObjCmd(
if (result != TCL_OK) {
goto done;
}
- if (start < 0) {
- start = 0;
+ if (start == TCL_INDEX_NONE) {
+ start = TCL_INDEX_START;
}
/*
@@ -4099,10 +4097,10 @@ Tcl_LsortObjCmd(
int result = TclIndexEncode(interp, indexv[j],
TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded);
- if ((result == TCL_OK) && (encoded == TCL_INDEX_NONE)) {
+ if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" cannot select an element "
- "from any list", Tcl_GetString(indexv[j])));
+ "from any list", TclGetString(indexv[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
result = TCL_ERROR;
@@ -4859,7 +4857,7 @@ SelectObjFromSublist(
return NULL;
}
if (currentObj == NULL) {
- if (index == TCL_INDEX_NONE) {
+ if (index == (int)TCL_INDEX_NONE) {
index = TCL_INDEX_END - infoPtr->indexv[i];
Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
"element end-%d missing from sublist \"%s\"",
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 441611e..a8a85f8 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -433,7 +433,7 @@ TclCompileIfCmd(
jumpFalseDist += 3;
TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else {
- Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
+ Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode);
}
}
}
@@ -606,7 +606,7 @@ TclCompileInfoCommandsCmd(
if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
goto notCompilable;
}
- bytes = Tcl_GetString(objPtr);
+ bytes = TclGetString(objPtr);
/*
* We require that the argument start with "::" and not have any of "*\[?"
@@ -1038,7 +1038,7 @@ TclCompileLassignCmd(
*/
TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
return TCL_OK;
}
@@ -1243,7 +1243,7 @@ TclCompileListCmd(
if (concat && numWords == 2) {
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
}
return TCL_OK;
}
@@ -1319,7 +1319,7 @@ TclCompileLrangeCmd(
tokenPtr = TokenAfter(listTokenPtr);
if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
- &idx1) != TCL_OK) || (idx1 == TCL_INDEX_NONE)) {
+ &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) {
return TCL_ERROR;
}
/*
@@ -1408,7 +1408,7 @@ TclCompileLinsertCmd(
CompileWord(envPtr, listTokenPtr, interp, 1);
if (parsePtr->numWords == 3) {
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
return TCL_OK;
}
@@ -1418,10 +1418,10 @@ TclCompileLinsertCmd(
}
TclEmitInstInt4( INST_LIST, i - 3, envPtr);
- if (idx == TCL_INDEX_START) {
+ if (idx == (int)TCL_INDEX_START) {
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- } else if (idx == TCL_INDEX_END) {
+ } else if (idx == (int)TCL_INDEX_END) {
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
} else {
/*
@@ -1436,7 +1436,7 @@ TclCompileLinsertCmd(
* differ in their interpretation of the "end" index.
*/
- if (idx < TCL_INDEX_END) {
+ if (idx < (int)TCL_INDEX_END) {
idx++;
}
TclEmitInstInt4( INST_OVER, 1, envPtr);
@@ -1444,7 +1444,7 @@ TclCompileLinsertCmd(
TclEmitInt4( idx - 1, envPtr);
TclEmitInstInt4( INST_REVERSE, 3, envPtr);
TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
}
@@ -1505,14 +1505,14 @@ TclCompileLreplaceCmd(
* we must defer to direct evaluation.
*/
- if (idx1 == TCL_INDEX_NONE) {
- suffixStart = TCL_INDEX_NONE;
- } else if (idx2 == TCL_INDEX_NONE) {
+ if (idx1 == (int)TCL_INDEX_NONE) {
+ suffixStart = (int)TCL_INDEX_NONE;
+ } else if (idx2 == (int)TCL_INDEX_NONE) {
suffixStart = idx1;
- } else if (idx2 == TCL_INDEX_END) {
- suffixStart = TCL_INDEX_NONE;
- } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END))
- || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) {
+ } else if (idx2 == (int)TCL_INDEX_END) {
+ suffixStart = (int)TCL_INDEX_NONE;
+ } else if (((idx2 < (int)TCL_INDEX_END) && (idx1 <= (int)TCL_INDEX_END))
+ || ((idx2 >= (int)TCL_INDEX_START) && (idx1 >= (int)TCL_INDEX_START))) {
suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
} else {
return TCL_ERROR;
@@ -1546,11 +1546,11 @@ TclCompileLreplaceCmd(
* and canonicalization side effects.
*/
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
return TCL_OK;
}
- if (idx1 != TCL_INDEX_START) {
+ if (idx1 != (int)TCL_INDEX_START) {
/* Prefix may not be empty; generate bytecode to push it */
if (emptyPrefix) {
TclEmitOpcode( INST_DUP, envPtr);
@@ -1570,7 +1570,7 @@ TclCompileLreplaceCmd(
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
}
- if (suffixStart == TCL_INDEX_NONE) {
+ if (suffixStart == (int)TCL_INDEX_NONE) {
TclEmitOpcode( INST_POP, envPtr);
if (emptyPrefix) {
PushStringLiteral(envPtr, "");
@@ -1578,7 +1578,7 @@ TclCompileLreplaceCmd(
} else {
/* Suffix may not be empty; generate bytecode to push it */
TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
if (!emptyPrefix) {
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
}
@@ -2295,8 +2295,8 @@ TclCompileRegsubCmd(
if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
goto done;
}
- if (Tcl_GetString(patternObj)[0] == '-') {
- if (strcmp(Tcl_GetString(patternObj), "--") != 0
+ if (TclGetString(patternObj)[0] == '-') {
+ if (strcmp(TclGetString(patternObj), "--") != 0
|| parsePtr->numWords == 5) {
goto done;
}
@@ -2361,7 +2361,7 @@ TclCompileRegsubCmd(
bytes++;
}
isSimpleGlob:
- for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
+ for (bytes = TclGetString(replacementObj); *bytes; bytes++) {
switch (*bytes) {
case '\\': case '&':
goto done;
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 4663fac..83ade0b 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -482,16 +482,16 @@ TclCompileStringInsertCmd(
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 3);
- if (idx == TCL_INDEX_START) {
+ if (idx == (int)TCL_INDEX_START) {
/* Prepend the insertion string */
OP4( REVERSE, 2);
OP1( STR_CONCAT1, 2);
- } else if (idx == TCL_INDEX_END) {
+ } else if (idx == (int)TCL_INDEX_END) {
/* Append the insertion string */
OP1( STR_CONCAT1, 2);
} else {
/* Prefix + insertion + suffix */
- if (idx < TCL_INDEX_END) {
+ if (idx < (int)TCL_INDEX_END) {
/* See comments in compiler for [linsert]. */
idx++;
}
@@ -821,7 +821,7 @@ TclCompileStringMatchCmd(
}
str = tokenPtr[1].start;
length = tokenPtr[1].size;
- if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) {
+ if ((length <= 1) || strncmp(str, "-nocase", length)) {
/*
* Fail at run time, not in compilation.
*/
@@ -1012,7 +1012,7 @@ TclCompileStringRangeCmd(
* the string the same as the start of the string.
*/
- if (idx1 == TCL_INDEX_NONE) {
+ if (idx1 == (int)TCL_INDEX_NONE) {
/* [string range $s end+1 $last] must be empty string */
OP( POP);
PUSH( "");
@@ -1027,7 +1027,7 @@ TclCompileStringRangeCmd(
* Token parsed as an index expression. We treat all indices after
* the string the same as the end of the string.
*/
- if (idx2 == TCL_INDEX_NONE) {
+ if (idx2 == (int)TCL_INDEX_NONE) {
/* [string range $s $first -1] must be empty string */
OP( POP);
PUSH( "");
@@ -1105,8 +1105,8 @@ TclCompileStringReplaceCmd(
* compile direct to bytecode implementing the no-op.
*/
- if ((last == TCL_INDEX_NONE) /* Know (last < 0) */
- || (first == TCL_INDEX_NONE) /* Know (first > end) */
+ if ((last == (int)TCL_INDEX_NONE) /* Know (last < 0) */
+ || (first == (int)TCL_INDEX_NONE) /* Know (first > end) */
/*
* Tricky to determine when runtime (last < first) can be
@@ -1117,7 +1117,7 @@ TclCompileStringReplaceCmd(
* (last <= TCL_INDEX END) && (last < first) => ACCEPT
* else => cannot tell REJECT
*/
- || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END)
+ || ((first <= (int)TCL_INDEX_END) && (last <= (int)TCL_INDEX_END)
&& (last < first)) /* Know (last < first) */
/*
* (first == TCL_INDEX_NONE) &&
@@ -1128,7 +1128,7 @@ TclCompileStringReplaceCmd(
* (last <= TCL_INDEX_END) => cannot tell REJECT
* else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT
*/
- || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START)
+ || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)
&& (last < first))) { /* Know (last < first) */
if (parsePtr->numWords == 5) {
tokenPtr = TokenAfter(tokenPtr);
@@ -1179,7 +1179,7 @@ TclCompileStringReplaceCmd(
* getting a guarantee that first <= last.
*/
- if ((first == TCL_INDEX_START) && (last >= TCL_INDEX_START)) {
+ if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) {
/* empty prefix */
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
@@ -1187,13 +1187,13 @@ TclCompileStringReplaceCmd(
if (last == INT_MAX) {
OP( POP); /* Pop original */
} else {
- OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
OP1( STR_CONCAT1, 2);
}
return TCL_OK;
}
- if ((last == TCL_INDEX_NONE) && (first <= TCL_INDEX_END)) {
+ if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) {
OP44( STR_RANGE_IMM, 0, first-1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
@@ -1210,19 +1210,19 @@ TclCompileStringReplaceCmd(
* are harmless when they are replaced by another empty string.
*/
- if (first == TCL_INDEX_START) {
+ if (first == (int)TCL_INDEX_START) {
/* empty prefix - build suffix only */
- if (last == TCL_INDEX_END) {
+ if (last == (int)TCL_INDEX_END) {
/* empty suffix too => empty result */
OP( POP); /* Pop original */
PUSH ( "");
return TCL_OK;
}
- OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
return TCL_OK;
} else {
- if (last == TCL_INDEX_END) {
+ if (last == (int)TCL_INDEX_END) {
/* empty suffix - build prefix only */
OP44( STR_RANGE_IMM, 0, first-1);
return TCL_OK;
@@ -1230,7 +1230,7 @@ TclCompileStringReplaceCmd(
OP( DUP);
OP44( STR_RANGE_IMM, 0, first-1);
OP4( REVERSE, 2);
- OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
OP1( STR_CONCAT1, 2);
return TCL_OK;
}
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 3b67796..3d40bef 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -3986,6 +3986,8 @@ extern const TclStubs *tclStubsPtr;
#define Tcl_AddObjErrorInfo(interp, message, length) \
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
#ifdef TCL_NO_DEPRECATED
+#undef Tcl_GetStringResult
+#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
#undef Tcl_Eval
#define Tcl_Eval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, -1, 0)
diff --git a/generic/tclIO.c b/generic/tclIO.c
index cf91307..118820a 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -3463,6 +3463,11 @@ Tcl_Close(
Tcl_ClearChannelHandlers(chan);
/*
+ * Cancel any outstanding timer.
+ */
+ Tcl_DeleteTimerHandler(statePtr->timer);
+
+ /*
* Invoke the registered close callbacks and delete their records.
*/
@@ -4447,6 +4452,8 @@ Write(
}
}
+ UpdateInterest(chanPtr);
+
return total;
}
@@ -8475,9 +8482,9 @@ UpdateInterest(
*
* - Tcl drops READABLE here, because it has data in its own
* buffers waiting to be read by the extension.
- * - A READABLE event is syntesized via timer.
+ * - A READABLE event is synthesized via timer.
* - The OS still reports the EXCEPTION condition on the file.
- * - And the extension gets the EXCPTION event first, and handles
+ * - And the extension gets the EXCEPTION event first, and handles
* this as EOF.
*
* End result ==> Premature end of reading from a file.
@@ -8503,6 +8510,16 @@ UpdateInterest(
}
}
}
+
+ if (!statePtr->timer
+ && mask & TCL_WRITABLE
+ && GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
+
+ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ ChannelTimerProc,chanPtr);
+ }
+
+
ChanWatch(chanPtr, mask);
}
@@ -8531,6 +8548,21 @@ ChannelTimerProc(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
+ Tcl_Preserve(statePtr);
+ statePtr->timer = NULL;
+ if (statePtr->interestMask & TCL_WRITABLE
+ && GotFlag(statePtr, CHANNEL_NONBLOCKING)
+ && !GotFlag(statePtr, BG_FLUSH_SCHEDULED)
+ ) {
+ /*
+ * Restart the timer in case a channel handler reenters the event loop
+ * before UpdateInterest gets called by Tcl_NotifyChannel.
+ */
+ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ ChannelTimerProc,chanPtr);
+ Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE);
+ }
+
if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
&& (statePtr->interestMask & TCL_READABLE)
&& (statePtr->inQueueHead != NULL)
@@ -8542,13 +8574,11 @@ ChannelTimerProc(
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc,chanPtr);
- Tcl_Preserve(statePtr);
Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
- Tcl_Release(statePtr);
} else {
- statePtr->timer = NULL;
UpdateInterest(chanPtr);
}
+ Tcl_Release(statePtr);
}
/*
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index cebc33f..23049fb 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -114,15 +114,15 @@ typedef struct {
int dead; /* Boolean signal that some operations
* should no longer be attempted. */
- Tcl_TimerToken readTimer; /*
+ Tcl_TimerToken readTimer; /*
A token for the timer that is scheduled in
order to call Tcl_NotifyChannel when the
- channel is readable
+ channel is readable
*/
- Tcl_TimerToken writeTimer; /*
+ Tcl_TimerToken writeTimer; /*
A token for the timer that is scheduled in
order to call Tcl_NotifyChannel when the
- channel is writable
+ channel is writable
*/
/*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9a2ef85..a2d19f9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3106,6 +3106,7 @@ MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc,
MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
MODULE_SCOPE int TclNokia770Doubles(void);
MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr);
+MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr);
MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, const char *operation,
const char *reason, int index);
@@ -4545,7 +4546,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
(bignum).alloc = (bignumPayload >> 15) & 0x7fff; \
(bignum).used = bignumPayload & 0x7fff; \
} \
- } while (0)
+ } while (0)
/*
*----------------------------------------------------------------
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 8096c25..030e471 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -27,6 +27,7 @@
typedef struct Link {
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
+ Namespace *nsPtr; /* Namespace containing Tcl variable */
Tcl_Obj *varName; /* Name of variable (must be global). This is
* needed during trace callbacks, since the
* actual variable may be aliased at that time
@@ -158,6 +159,8 @@ Tcl_LinkVar(
{
Tcl_Obj *objPtr;
Link *linkPtr;
+ Namespace *dummy;
+ const char *name;
int code;
linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
@@ -170,6 +173,7 @@ Tcl_LinkVar(
linkPtr = ckalloc(sizeof(Link));
linkPtr->interp = interp;
+ linkPtr->nsPtr = NULL;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
@@ -196,6 +200,11 @@ Tcl_LinkVar(
LinkFree(linkPtr);
return TCL_ERROR;
}
+
+ TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
+ &(linkPtr->nsPtr), &dummy, &dummy, &name);
+ linkPtr->nsPtr->refCount++;
+
code = Tcl_TraceVar2(interp, varName, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
@@ -240,6 +249,8 @@ Tcl_LinkArray(
{
Tcl_Obj *objPtr;
Link *linkPtr;
+ Namespace *dummy;
+ const char *name;
int code;
if (size < 1) {
@@ -362,6 +373,11 @@ Tcl_LinkArray(
linkPtr->interp = interp;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
+
+ TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
+ &(linkPtr->nsPtr), &dummy, &dummy, &name);
+ linkPtr->nsPtr->refCount++;
+
objPtr = ObjValue(linkPtr);
if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
@@ -376,8 +392,6 @@ Tcl_LinkArray(
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
- } else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj((int) linkPtr->addr));
}
return code;
}
@@ -747,7 +761,7 @@ LinkTraceProc(
*/
if (flags & TCL_TRACE_UNSETS) {
- if (Tcl_InterpDeleted(interp)) {
+ if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) {
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
@@ -1497,6 +1511,9 @@ static void
LinkFree(
Link *linkPtr) /* Structure describing linked variable. */
{
+ if (linkPtr->nsPtr) {
+ TclNsDecrRefCount(linkPtr->nsPtr);
+ }
if (linkPtr->flags & LINK_ALLOC_ADDR) {
ckfree(linkPtr->addr);
}
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index b553880..bbe357d 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1086,6 +1086,13 @@ Tcl_DeleteNamespace(
}
TclNsDecrRefCount(nsPtr);
}
+
+int
+TclNamespaceDeleted(
+ Namespace *nsPtr)
+{
+ return (nsPtr->flags & NS_DYING) ? 1 : 0;
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 0440395..e9cc0f0 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -346,14 +346,14 @@ InitFoundation(
*/
Tcl_DStringInit(&buffer);
- for (i=0 ; defineCmds[i].name ; i++) {
+ for (i = 0 ; defineCmds[i].name ; i++) {
TclDStringAppendLiteral(&buffer, "::oo::define::");
Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
Tcl_DStringFree(&buffer);
}
- for (i=0 ; objdefCmds[i].name ; i++) {
+ for (i = 0 ; objdefCmds[i].name ; i++) {
TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
@@ -373,10 +373,10 @@ InitFoundation(
* Basic method declarations for the core classes.
*/
- for (i=0 ; objMethods[i].name ; i++) {
+ for (i = 0 ; objMethods[i].name ; i++) {
TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
}
- for (i=0 ; clsMethods[i].name ; i++) {
+ for (i = 0 ; clsMethods[i].name ; i++) {
TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
}
@@ -388,7 +388,7 @@ InitFoundation(
TclNewLiteralStringObj(namePtr, "new");
Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
- namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
+ namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
(Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
@@ -667,10 +667,8 @@ AllocObject(
Tcl_ResetResult(interp);
}
-
configNamespace:
-
- ((Namespace *)oPtr->namespacePtr)->refCount++;
+ ((Namespace *) oPtr->namespacePtr)->refCount++;
/*
* Make the namespace know about the helper commands. This grants access
@@ -874,10 +872,14 @@ TclOODeleteDescendants(
if (clsPtr->mixinSubs.num > 0) {
while (clsPtr->mixinSubs.num > 0) {
- mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1];
- /* This condition also covers the case where mixinSubclassPtr ==
+ mixinSubclassPtr =
+ clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1];
+
+ /*
+ * This condition also covers the case where mixinSubclassPtr ==
* clsPtr
*/
+
if (!Deleted(mixinSubclassPtr->thisPtr)
&& !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
Tcl_DeleteCommandFromToken(interp,
@@ -897,7 +899,7 @@ TclOODeleteDescendants(
if (clsPtr->subclasses.num > 0) {
while (clsPtr->subclasses.num > 0) {
- subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1];
+ subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1];
if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
&& !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
Tcl_DeleteCommandFromToken(interp,
@@ -918,7 +920,8 @@ TclOODeleteDescendants(
if (clsPtr->instances.num > 0) {
while (clsPtr->instances.num > 0) {
- instancePtr = clsPtr->instances.list[clsPtr->instances.num-1];
+ instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1];
+
/*
* This condition also covers the case where instancePtr == oPtr
*/
@@ -1119,8 +1122,8 @@ ObjectNamespaceDeleted(
if (Deleted(oPtr)) {
/*
- * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this
- * guard could be removed.
+ * TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
+ * this guard could be removed.
*/
return;
@@ -1134,7 +1137,10 @@ ObjectNamespaceDeleted(
oPtr->flags |= OBJECT_DELETED;
- /* Let the dominoes fall */
+ /*
+ * Let the dominoes fall!
+ */
+
if (oPtr->classPtr) {
TclOODeleteDescendants(interp, oPtr);
}
@@ -1150,8 +1156,8 @@ ObjectNamespaceDeleted(
CallContext *contextPtr =
TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
int result;
-
Tcl_InterpState state;
+
oPtr->flags |= DESTRUCTOR_CALLED;
if (contextPtr != NULL) {
@@ -1170,12 +1176,12 @@ ObjectNamespaceDeleted(
/*
* Instruct everyone to no longer use any allocated fields of the object.
- * Also delete the command that refers to the object at this point (if
- * it still exists) because otherwise its pointer to the object
- * points into freed memory.
+ * Also delete the command that refers to the object at this point (if it
+ * still exists) because otherwise its pointer to the object points into
+ * freed memory.
*/
- if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) {
+ if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
/*
* Something has already started the command deletion process. We can
* go ahead and clean up the the namespace,
@@ -1201,10 +1207,7 @@ ObjectNamespaceDeleted(
* methods on the object.
*/
- /*
- * TODO: Should this be protected with a * !IsRoot() condition?
- */
-
+ /* TODO: Should this be protected with a !IsRoot() condition? */
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
if (oPtr->mixins.num > 0) {
@@ -1765,7 +1768,6 @@ TclNRNewObjectInstance(
TclPushTailcallPoint(interp);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
-
Object *
TclNewObjectInstanceCommon(
@@ -1780,7 +1782,6 @@ TclNewObjectInstanceCommon(
const char *simpleName = NULL;
Namespace *nsPtr = NULL, *dummy;
Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- int isNew;
if (nameStr) {
TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
@@ -1790,21 +1791,14 @@ TclNewObjectInstanceCommon(
* Disallow creation of an object over an existing command.
*/
- hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew);
- if (!isNew) {
+ hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
+ if (hPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create object \"%s\": command already exists with"
" that name", nameStr));
Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
return NULL;
}
-
- /*
- * We could make a hash entry! Don't actually want to do that here so
- * nuke it immediately because we'll create it properly soon.
- */
-
- Tcl_DeleteHashEntry(hPtr);
}
/*
@@ -1837,8 +1831,6 @@ TclNewObjectInstanceCommon(
return oPtr;
}
-
-
static int
FinalizeAlloc(
ClientData data[],
@@ -1974,7 +1966,11 @@ Tcl_CopyObjectInstance(
if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOOAddToInstances(o2Ptr, mixinPtr);
}
- /* For the reference just created in DUPLICATE */
+
+ /*
+ * For the reference just created in DUPLICATE.
+ */
+
AddRef(mixinPtr->thisPtr);
}
@@ -2012,6 +2008,7 @@ Tcl_CopyObjectInstance(
o2Ptr->flags = oPtr->flags & ~(
OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
+
/*
* Copy the object's metadata.
*/
@@ -2075,9 +2072,11 @@ Tcl_CopyObjectInstance(
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOOAddToSubclasses(cls2Ptr, superPtr);
- /* For the new item in cls2Ptr->superclasses that memcpy just
- * created
+ /*
+ * For the new item in cls2Ptr->superclasses that memcpy just
+ * created.
*/
+
AddRef(superPtr->thisPtr);
}
@@ -2121,7 +2120,11 @@ Tcl_CopyObjectInstance(
DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
FOREACH(mixinPtr, cls2Ptr->mixins) {
TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
- /* For the copy just created in DUPLICATE */
+
+ /*
+ * For the copy just created in DUPLICATE.
+ */
+
AddRef(mixinPtr->thisPtr);
}
@@ -2783,7 +2786,7 @@ Tcl_ObjectContextInvokeNext(
int savedSkip = contextPtr->skip;
int result;
- if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+ if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless the
* interpreter is being torn down, in which case we might be getting
@@ -2852,7 +2855,7 @@ TclNRObjectContextInvokeNext(
{
register CallContext *contextPtr = (CallContext *) context;
- if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+ if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless the
* interpreter is being torn down, in which case we might be getting
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index ace7fd7..c0d2e64 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -328,7 +328,7 @@ TclOOInvokeContext(
if (contextPtr->index == 0) {
int i;
- for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+ for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
AddRef(contextPtr->callPtr->chain[i].mPtr);
}
@@ -406,7 +406,7 @@ FinalizeMethodRefs(
CallContext *contextPtr = data[0];
int i;
- for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
+ for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
}
return result;
@@ -641,7 +641,10 @@ SortMethodNames(
return i;
}
-/* Comparator for SortMethodNames */
+/*
+ * Comparator for SortMethodNames
+ */
+
static int
CmpStr(
const void *ptr1,
@@ -1004,7 +1007,7 @@ AddMethodToCallChain(
* any leading filters.
*/
- for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) {
+ for (i = cbPtr->filterLength ; i < callPtr->numChain ; i++) {
if (callPtr->chain[i].mPtr == mPtr &&
callPtr->chain[i].isFilter == (doneFilters != NULL)) {
/*
@@ -1016,8 +1019,8 @@ AddMethodToCallChain(
Class *declCls = callPtr->chain[i].filterDeclarer;
- for (; i+1<callPtr->numChain ; i++) {
- callPtr->chain[i] = callPtr->chain[i+1];
+ for (; i + 1 < callPtr->numChain ; i++) {
+ callPtr->chain[i] = callPtr->chain[i + 1];
}
callPtr->chain[i].mPtr = mPtr;
callPtr->chain[i].isFilter = (doneFilters != NULL);
@@ -1817,7 +1820,7 @@ TclOORenderCallChain(
*/
objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
- for (i=0 ; i<callPtr->numChain ; i++) {
+ for (i = 0 ; i < callPtr->numChain ; i++) {
struct MInvoke *miPtr = &callPtr->chain[i];
descObjs[0] =
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 65d6ea1..6a00018 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -50,6 +50,12 @@ struct DeclaredSlot {
resolver, NULL, NULL}}
/*
+ * A [string match] pattern used to determine if a method should be exported.
+ */
+
+#define PUBLIC_PATTERN "[a-z]*"
+
+/*
* Forward declarations.
*/
@@ -278,7 +284,7 @@ TclOOObjectSetFilters(
} else {
filtersList = ckrealloc(oPtr->filters.list, size);
}
- for (i=0 ; i<numFilters ; i++) {
+ for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
Tcl_IncrRefCount(filters[i]);
}
@@ -337,7 +343,7 @@ TclOOClassSetFilters(
} else {
filtersList = ckrealloc(classPtr->filters.list, size);
}
- for (i=0 ; i<numFilters ; i++) {
+ for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
Tcl_IncrRefCount(filters[i]);
}
@@ -400,7 +406,11 @@ TclOOObjectSetMixins(
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr != oPtr->selfCls) {
TclOOAddToInstances(oPtr, mixinPtr);
- /* For the new copy created by memcpy */
+
+ /*
+ * For the new copy created by memcpy().
+ */
+
AddRef(mixinPtr->thisPtr);
}
}
@@ -452,7 +462,11 @@ TclOOClassSetMixins(
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
- /* For the new copy created by memcpy */
+
+ /*
+ * For the new copy created by memcpy.
+ */
+
AddRef(mixinPtr->thisPtr);
}
}
@@ -724,15 +738,16 @@ TclOOUnknownDefinition(
* Got one match, and only one match!
*/
- Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1));
+ Tcl_Obj **newObjv =
+ TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
int result;
newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
Tcl_IncrRefCount(newObjv[0]);
if (objc > 2) {
- memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2));
+ memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
}
- result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
+ result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
Tcl_DecrRefCount(newObjv[0]);
TclStackFree(interp, newObjv);
return result;
@@ -1039,17 +1054,20 @@ MagicDefinitionInvoke(
obj2Ptr = Tcl_NewObj();
cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
if (cmd == NULL) {
- /* punt this case! */
+ /*
+ * Punt this case!
+ */
+
Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
} else {
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
/* TODO: overflow? */
- Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset);
+ Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
- result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE);
+ result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE);
if (isRoot) {
TclResetRewriteEnsemble(interp, 1);
}
@@ -1685,7 +1703,7 @@ TclOODefineDeleteMethodObjCmd(
return TCL_ERROR;
}
- for (i=1 ; i<objc ; i++) {
+ for (i = 1; i < objc; i++) {
/*
* Delete the method structure from the appropriate hash table.
*/
@@ -1811,7 +1829,7 @@ TclOODefineExportObjCmd(
return TCL_ERROR;
}
- for (i=1 ; i<objc ; i++) {
+ for (i = 1; i < objc; i++) {
/*
* Exporting is done by adding the PUBLIC_METHOD flag to the method
* record. If there is no such method in this object or class (i.e.
@@ -1904,7 +1922,7 @@ TclOODefineForwardObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
}
- isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
? PUBLIC_METHOD : 0;
if (IsPrivateDefine(interp)) {
isPublic = TRUE_PRIVATE_METHOD;
@@ -1914,7 +1932,7 @@ TclOODefineForwardObjCmd(
* Create the method structure.
*/
- prefixObj = Tcl_NewListObj(objc-2, objv+2);
+ prefixObj = Tcl_NewListObj(objc - 2, objv + 2);
if (isInstanceForward) {
mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
prefixObj);
@@ -2002,7 +2020,7 @@ TclOODefineMethodObjCmd(
if (IsPrivateDefine(interp)) {
isPublic = TRUE_PRIVATE_METHOD;
} else {
- isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
? PUBLIC_METHOD : 0;
}
}
@@ -2124,7 +2142,7 @@ TclOODefineUnexportObjCmd(
return TCL_ERROR;
}
- for (i=1 ; i<objc ; i++) {
+ for (i = 1; i < objc; i++) {
/*
* Unexporting is done by removing the PUBLIC_METHOD flag from the
* method record. If there is no such method in this object or class
@@ -2340,7 +2358,7 @@ ClassFilterSet(
int filterc;
Tcl_Obj **filterv;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
@@ -2424,7 +2442,7 @@ ClassMixinSet(
Tcl_Obj **mixinv;
Class **mixins;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
@@ -2445,7 +2463,7 @@ ClassMixinSet(
mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
- for (i=0 ; i<mixinc ; i++) {
+ for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
@@ -2529,7 +2547,7 @@ ClassSuperSet(
Tcl_Obj **superv;
Class **superclasses, *superPtr;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"superclassList");
return TCL_ERROR;
@@ -2576,14 +2594,14 @@ ClassSuperSet(
superc = 1;
AddRef(superclasses[0]->thisPtr);
} else {
- for (i=0 ; i<superc ; i++) {
+ for (i = 0; i < superc; i++) {
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
i--;
goto failedAfterAlloc;
}
- for (j=0 ; j<i ; j++) {
+ for (j = 0; j < i; j++) {
if (superclasses[j] == superclasses[i]) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"class should only be a direct superclass once",
@@ -2705,7 +2723,7 @@ ClassVarsSet(
Tcl_Obj **varv;
int i;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
@@ -2724,7 +2742,7 @@ ClassVarsSet(
return TCL_ERROR;
}
- for (i=0 ; i<varc ; i++) {
+ for (i = 0; i < varc; i++) {
const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
@@ -2803,7 +2821,7 @@ ObjFilterSet(
int filterc;
Tcl_Obj **filterv;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"filterList");
return TCL_ERROR;
@@ -2877,7 +2895,7 @@ ObjMixinSet(
Class **mixins;
int i;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"mixinList");
return TCL_ERROR;
@@ -2892,7 +2910,7 @@ ObjMixinSet(
mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
- for (i=0 ; i<mixinc ; i++) {
+ for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
@@ -2967,7 +2985,7 @@ ObjVarsSet(
int varc, i;
Tcl_Obj **varv;
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"variableList");
return TCL_ERROR;
@@ -2980,7 +2998,7 @@ ObjVarsSet(
return TCL_ERROR;
}
- for (i=0 ; i<varc ; i++) {
+ for (i = 0; i < varc; i++) {
const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 5a03421..4d14f01 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -464,7 +464,6 @@ Tcl_SetResult(
ResetObjResult(iPtr);
}
-#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -488,9 +487,6 @@ Tcl_GetStringResult(
register Tcl_Interp *interp)/* Interpreter whose result to return. */
{
Interp *iPtr = (Interp *) interp;
-#ifdef TCL_NO_DEPRECATED
- return Tcl_GetString(iPtr->objResultPtr);
-#else
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
@@ -501,8 +497,8 @@ Tcl_GetStringResult(
TCL_VOLATILE);
}
return iPtr->result;
-#endif
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index e7cb2c5..c9abb1a 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -1849,15 +1849,15 @@ RefineApproximation(
*/
msb = binExponent + M2; /* 1008 */
- nDigits = msb / DIGIT_BIT + 1;
+ nDigits = msb / MP_DIGIT_BIT + 1;
mp_init_size(&twoMv, nDigits);
- i = (msb % DIGIT_BIT + 1);
+ i = (msb % MP_DIGIT_BIT + 1);
twoMv.used = nDigits;
significand *= SafeLdExp(1.0, i);
while (--nDigits >= 0) {
twoMv.dp[nDigits] = (mp_digit) significand;
significand -= (mp_digit) significand;
- significand = SafeLdExp(significand, DIGIT_BIT);
+ significand = SafeLdExp(significand, MP_DIGIT_BIT);
}
for (i = 0; i <= 8; ++i) {
if (M5 & (1 << i)) {
@@ -3145,7 +3145,7 @@ ShouldBankerRoundUpPowD(
int isodd) /* 1 if the digit is odd, 0 if even. */
{
int i;
- static const mp_digit topbit = ((mp_digit)1) << (DIGIT_BIT - 1);
+ static const mp_digit topbit = ((mp_digit)1) << (MP_DIGIT_BIT - 1);
if (b->used < sd || (b->dp[sd-1] & topbit) == 0) {
return 0;
@@ -4214,8 +4214,8 @@ TclDoubleDigits(
* in the denominator' case.
*/
- if (s2 % DIGIT_BIT != 0) {
- int delta = DIGIT_BIT - (s2 % DIGIT_BIT);
+ if (s2 % MP_DIGIT_BIT != 0) {
+ int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);
b2 += delta;
m2plus += delta;
@@ -4223,7 +4223,7 @@ TclDoubleDigits(
s2 += delta;
}
return ShorteningBignumConversionPowD(&d, bw, b2, b5,
- m2plus, m2minus, m5, s2/DIGIT_BIT, k, len, ilim, ilim1,
+ m2plus, m2minus, m5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1,
decpt, endPtr);
} else {
/*
@@ -4270,14 +4270,14 @@ TclDoubleDigits(
* in the denominator' case.
*/
- if (s2 % DIGIT_BIT != 0) {
- int delta = DIGIT_BIT - (s2 % DIGIT_BIT);
+ if (s2 % MP_DIGIT_BIT != 0) {
+ int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);
b2 += delta;
s2 += delta;
}
return StrictBignumConversionPowD(&d, bw, b2, b5,
- s2/DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
+ s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
} else {
/*
* There are no helpful special cases, but at least we know in
@@ -4402,7 +4402,7 @@ TclInitDoubleConversion(void)
+ 0.5 * log(10.)) / log(10.));
minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG)
* log((double) FLT_RADIX) / log(10.));
- log10_DIGIT_MAX = (int) floor(DIGIT_BIT * log(2.) / log(10.));
+ log10_DIGIT_MAX = (int) floor(MP_DIGIT_BIT * log(2.) / log(10.));
/*
* Nokia 770's software-emulated floating point is "middle endian": the
@@ -4606,7 +4606,7 @@ TclBignumToDouble(
r = 0.0;
for (i=b.used-1 ; i>=0 ; --i) {
- r = ldexp(r, DIGIT_BIT) + b.dp[i];
+ r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
mp_clear(&b);
@@ -4675,7 +4675,7 @@ TclCeil(
mp_add_d(&b, 1, &b);
}
for (i=b.used-1 ; i>=0 ; --i) {
- r = ldexp(r, DIGIT_BIT) + b.dp[i];
+ r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
r = ldexp(r, bits - mantBits);
}
@@ -4725,7 +4725,7 @@ TclFloor(
mp_copy(a, &b);
}
for (i=b.used-1 ; i>=0 ; --i) {
- r = ldexp(r, DIGIT_BIT) + b.dp[i];
+ r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
r = ldexp(r, bits - mantBits);
}
@@ -4787,7 +4787,7 @@ BignumToBiasedFrExp(
r = 0.0;
for (i=b.used-1; i>=0; --i) {
- r = ldexp(r, DIGIT_BIT) + b.dp[i];
+ r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
mp_clear(&b);
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 6652f15..547ece1 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2270,11 +2270,11 @@ Tcl_AppendFormatToObj(
}
#endif
} else if (useBig && big.used) {
- int leftover = (big.used * DIGIT_BIT) % numBits;
- mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover);
+ int leftover = (big.used * MP_DIGIT_BIT) % numBits;
+ mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover);
numDigits = 1 +
- (((Tcl_WideInt) big.used * DIGIT_BIT) / numBits);
+ (((Tcl_WideInt) big.used * MP_DIGIT_BIT) / numBits);
while ((mask & big.dp[big.used-1]) == 0) {
numDigits--;
mask >>= numBits;
@@ -2310,9 +2310,9 @@ Tcl_AppendFormatToObj(
if (useBig && big.used) {
if (index < big.used && (size_t) shift <
- CHAR_BIT*sizeof(Tcl_WideUInt) - DIGIT_BIT) {
+ CHAR_BIT*sizeof(Tcl_WideUInt) - MP_DIGIT_BIT) {
bits |= ((Tcl_WideUInt) big.dp[index++]) << shift;
- shift += DIGIT_BIT;
+ shift += MP_DIGIT_BIT;
}
shift -= numBits;
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index ec6e735..c9a195f 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -368,6 +368,8 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig
# define Tcl_Eval 0
# undef Tcl_GlobalEval
# define Tcl_GlobalEval 0
+# undef Tcl_GetStringResult
+# define Tcl_GetStringResult 0
# undef Tcl_SaveResult
# define Tcl_SaveResult 0
# undef Tcl_RestoreResult
diff --git a/generic/tclTest.c b/generic/tclTest.c
index f301ebc..8476ecb 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -971,8 +971,10 @@ AsyncHandlerProc(
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
- asyncPtr = asyncPtr->nextPtr) {
- if (asyncPtr->id == id) break;
+ asyncPtr = asyncPtr->nextPtr) {
+ if (asyncPtr->id == id) {
+ break;
+ }
}
Tcl_MutexUnlock(&asyncTestMutex);
@@ -3325,10 +3327,7 @@ TestlinkarrayCmd(
};
int optionIndex, typeIndex, readonly, i, size, length;
char *name, *arg;
- long addr; /* Wrong on Windows, but that's MS's fault for
- * not supporting <stdint.h> correctly. They
- * can suffer the warnings; the rest of us
- * shouldn't have to! */
+ Tcl_WideInt addr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option args");
@@ -3386,7 +3385,7 @@ TestlinkarrayCmd(
*/
if (i < objc) {
- if (Tcl_GetLongFromObj(interp, objv[i], &addr) == TCL_ERROR) {
+ if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong address value", -1));
return TCL_ERROR;
@@ -3394,7 +3393,7 @@ TestlinkarrayCmd(
} else {
addr = 0;
}
- return Tcl_LinkArray(interp, name, (void *) addr,
+ return Tcl_LinkArray(interp, name, INT2PTR(addr),
LinkTypes[typeIndex] | readonly, size);
}
return TCL_OK;
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 15c87b5..ea80320 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -310,8 +310,8 @@ TclCreateAbsoluteTimerHandler(
timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);
/*
- * Add the event to the queue in the correct position
- * (ordered by event firing time).
+ * Add the event to the queue in the correct position (ordered by event
+ * firing time).
*/
for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
@@ -1013,8 +1013,8 @@ AfterDelay(
Tcl_GetTime(&now);
endTime = now;
- endTime.sec += (long)(ms/1000);
- endTime.usec += ((int)(ms%1000))*1000;
+ endTime.sec += (long)(ms / 1000);
+ endTime.usec += ((int)(ms % 1000)) * 1000;
if (endTime.usec >= 1000000) {
endTime.sec++;
endTime.usec -= 1000000;
@@ -1042,17 +1042,17 @@ AfterDelay(
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
- if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
- diff = 1;
- }
+ if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
+ diff = 1;
+ }
if (diff > 0) {
- Tcl_Sleep((int) diff);
- if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
- break;
- }
+ Tcl_Sleep((long) diff);
+ if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
+ break;
+ }
} else {
- break;
- }
+ break;
+ }
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h
index 26eef26..cc9f286 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -1,14 +1,6 @@
-/* LibTomMath, multiple-precision integer library -- Tom St Denis
- *
- * LibTomMath is a library that provides multiple-precision
- * integer arithmetic as well as number theoretic functionality.
- *
- * The library was designed directly after the MPI library by
- * Michael Fromberger but has been written from scratch with
- * additional optimizations in place.
- *
- * SPDX-License-Identifier: Unlicense
- */
+/* LibTomMath, multiple-precision integer library -- Tom St Denis */
+/* SPDX-License-Identifier: Unlicense */
+
#ifndef BN_H_
#define BN_H_
@@ -115,29 +107,30 @@ typedef unsigned long long mp_word;
#define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1))
#define MP_DIGIT_MAX MP_MASK
-/* equalities */
+typedef int mp_sign;
+#define MP_ZPOS 0 /* positive integer */
+#define MP_NEG 1 /* negative */
+typedef int mp_ord;
#define MP_LT -1 /* less than */
#define MP_EQ 0 /* equal to */
#define MP_GT 1 /* greater than */
-
-#define MP_ZPOS 0 /* positive integer */
-#define MP_NEG 1 /* negative */
-
+typedef int mp_bool;
+#define MP_YES 1 /* yes response */
+#define MP_NO 0 /* no response */
+typedef int mp_err;
#define MP_OKAY 0 /* ok result */
+#define MP_ERR -1 /* unknown error */
#define MP_MEM -2 /* out of mem */
#define MP_VAL -3 /* invalid input */
#define MP_RANGE MP_VAL
#define MP_ITER -4 /* Max. iterations reached */
-#define MP_YES 1 /* yes response */
-#define MP_NO 0 /* no response */
-
/* Primality generation flags */
#define LTM_PRIME_BBS 0x0001 /* BBS style prime */
#define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */
#define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */
-typedef int mp_err;
+/* tunable cutoffs */
/* define this to use lower memory usage routines (exptmods mostly) */
/* #define MP_LOW_MEM */
@@ -146,6 +139,8 @@ typedef int mp_err;
#ifndef MP_PREC
# ifndef MP_LOW_MEM
# define MP_PREC 32 /* default digits of precision */
+# elif defined(MP_8BIT)
+# define MP_PREC 16 /* default digits of precision */
# else
# define MP_PREC 8 /* default digits of precision */
# endif
@@ -154,6 +149,45 @@ typedef int mp_err;
/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
#define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))
+/*
+ * MP_WUR - warn unused result
+ * ---------------------------
+ *
+ * The result of functions annotated with MP_WUR must be
+ * checked and cannot be ignored.
+ *
+ * Most functions in libtommath return an error code.
+ * This error code must be checked in order to prevent crashes or invalid
+ * results.
+ *
+ * If you still want to avoid the error checks for quick and dirty programs
+ * without robustness guarantees, you can `#define MP_WUR` before including
+ * tommath.h, disabling the warnings.
+ */
+#ifndef MP_WUR
+# if defined(__GNUC__) && __GNUC__ >= 4
+# define MP_WUR __attribute__((warn_unused_result))
+# else
+# define MP_WUR
+# endif
+#endif
+
+#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 301)
+# define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x)))
+# define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s)
+# define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s)
+#elif defined(_MSC_VER) && _MSC_VER >= 1500
+# define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x))
+# define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
+#else
+# define MP_DEPRECATED
+# define MP_DEPRECATED_PRAGMA(s)
+#endif
+
+#define USED(m) ((m)->used)
+#define DIGIT(m,k) ((m)->dp[(k)])
+#define SIGN(m) ((m)->sign)
+
/* the infamous mp_int structure */
#ifndef MP_INT_DECLARED
#define MP_INT_DECLARED
@@ -168,10 +202,6 @@ struct mp_int {
typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);
-#define USED(m) ((m)->used)
-#define DIGIT(m, k) ((m)->dp[(k)])
-#define SIGN(m) ((m)->sign)
-
/* error code to char* string */
const char *mp_error_to_string(int code);
diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h
index 165e3b7..c5ed4d5 100644
--- a/generic/tclTomMathDecls.h
+++ b/generic/tclTomMathDecls.h
@@ -45,8 +45,11 @@
/* Rename the global symbols in libtommath to avoid linkage conflicts */
#define bn_reverse TclBN_reverse
+#define s_mp_reverse TclBN_reverse
#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs
+#define s_mp_mul_digs_fast TclBN_fast_s_mp_mul_digs
#define fast_s_mp_sqr TclBN_fast_s_mp_sqr
+#define s_mp_sqr_fast TclBN_fast_s_mp_sqr
#define mp_add TclBN_mp_add
#define mp_add_d TclBN_mp_add_d
#define mp_and TclBN_mp_and
@@ -79,7 +82,9 @@
#define mp_init_set_int TclBN_mp_init_set_int
#define mp_init_size TclBN_mp_init_size
#define mp_karatsuba_mul TclBN_mp_karatsuba_mul
+#define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul
#define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr
+#define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr
#define mp_lshd TclBN_mp_lshd
#define mp_mod TclBN_mp_mod
#define mp_mod_2d TclBN_mp_mod_2d
@@ -108,7 +113,9 @@
#define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin
#define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n
#define mp_toom_mul TclBN_mp_toom_mul
+#define s_mp_toom_mul TclBN_mp_toom_mul
#define mp_toom_sqr TclBN_mp_toom_sqr
+#define s_mp_toom_sqr TclBN_mp_toom_sqr
#define mp_toradix_n TclBN_mp_toradix_n
#define mp_unsigned_bin_size TclBN_mp_unsigned_bin_size
#define mp_xor TclBN_mp_xor
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index c3887f0..3d1941c 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -381,6 +381,7 @@ static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index,
static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path,
Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
+static void ZipfsExitHandler(ClientData clientData);
static void ZipfsSetup(void);
static int ZipChannelClose(void *instanceData,
Tcl_Interp *interp);
@@ -1286,6 +1287,7 @@ ZipFSCatalogFilesystem(
*zf = *zf0;
zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
+ Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf);
zf->mountPointLen = strlen(zf->mountPoint);
zf->nameLength = strlen(zipname);
zf->name = ckalloc(zf->nameLength + 1);
@@ -1679,9 +1681,16 @@ TclZipfs_Mount(
return TCL_ERROR;
}
if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
+ ckfree(zf);
return TCL_ERROR;
}
- return ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname);
+ if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname)
+ != TCL_OK) {
+ ckfree(zf);
+ return TCL_ERROR;
+ }
+ ckfree(zf);
+ return TCL_OK;
}
/*
@@ -1844,6 +1853,7 @@ TclZipfs_Unmount(
ckfree(z);
}
ZipFSCloseArchive(interp, zf);
+ Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf);
ckfree(zf);
unmounted = 1;
done:
@@ -4837,6 +4847,17 @@ ZipfsAppHookFindTclInit(
return TCL_ERROR;
}
+static void
+ZipfsExitHandler(
+ ClientData clientData)
+{
+ ZipFile *zf = (ZipFile *)clientData;
+
+ if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) {
+ Tcl_Panic("tried to unmount busy filesystem");
+ }
+}
+
/*
*-------------------------------------------------------------------------
*