diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2019-05-17 07:31:47 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2019-05-17 07:31:47 (GMT) |
commit | c54b6957b8f0577a8d2789b9cc88a04a7da7a478 (patch) | |
tree | a88c9c80571094587464060f1a831a268d8e8302 /generic | |
parent | 0f34d49b76e87e5f454a9b468e981bc71f43907c (diff) | |
parent | 503da2614f2490195b2bd436c44cc52f3678becd (diff) | |
download | tcl-c54b6957b8f0577a8d2789b9cc88a04a7da7a478.zip tcl-c54b6957b8f0577a8d2789b9cc88a04a7da7a478.tar.gz tcl-c54b6957b8f0577a8d2789b9cc88a04a7da7a478.tar.bz2 |
merge core-8-branch
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tclBasic.c | 187 | ||||
-rw-r--r-- | generic/tclBinary.c | 5 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 40 | ||||
-rw-r--r-- | generic/tclCompCmdsGR.c | 48 | ||||
-rw-r--r-- | generic/tclCompCmdsSZ.c | 36 | ||||
-rw-r--r-- | generic/tclDecls.h | 2 | ||||
-rw-r--r-- | generic/tclIO.c | 40 | ||||
-rw-r--r-- | generic/tclIORChan.c | 8 | ||||
-rw-r--r-- | generic/tclInt.h | 3 | ||||
-rw-r--r-- | generic/tclLink.c | 23 | ||||
-rw-r--r-- | generic/tclNamesp.c | 7 | ||||
-rw-r--r-- | generic/tclOO.c | 89 | ||||
-rw-r--r-- | generic/tclOOCall.c | 17 | ||||
-rw-r--r-- | generic/tclOODefineCmds.c | 76 | ||||
-rw-r--r-- | generic/tclResult.c | 6 | ||||
-rw-r--r-- | generic/tclStrToD.c | 30 | ||||
-rw-r--r-- | generic/tclStringObj.c | 10 | ||||
-rw-r--r-- | generic/tclStubInit.c | 2 | ||||
-rw-r--r-- | generic/tclTest.c | 15 | ||||
-rw-r--r-- | generic/tclTimer.c | 26 | ||||
-rw-r--r-- | generic/tclTomMath.h | 78 | ||||
-rw-r--r-- | generic/tclTomMathDecls.h | 7 | ||||
-rw-r--r-- | generic/tclZipfs.c | 23 |
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"); + } +} + /* *------------------------------------------------------------------------- * |