diff options
Diffstat (limited to 'generic')
39 files changed, 2639 insertions, 818 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 1cf0b89..529db61 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -639,9 +639,10 @@ declare 172 { declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } -declare 174 { - const char *Tcl_GetStringResult(Tcl_Interp *interp) -} +# Removed in 9.0, replaced by macro. +#declare 174 { +# const char *Tcl_GetStringResult(Tcl_Interp *interp) +#} # Removed in 9.0, replaced by macro. #declare 175 {deprecated {No longer in use, changed to macro}} { # const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, @@ -687,7 +688,7 @@ declare 186 { Tcl_DString *resultPtr) } declare 187 { - int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr, + int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, int type) } @@ -2432,6 +2433,12 @@ declare 643 { int Tcl_IsShared(Tcl_Obj *objPtr) } +# TIP#312 New Tcl_LinkArray() function +declare 644 { + int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr, + int type, int size) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index 98c1f2b..46561b5 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -936,6 +936,8 @@ typedef struct Tcl_DString { #endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 +#define TCL_LINK_CHARS 15 +#define TCL_LINK_BINARY 16 #define TCL_LINK_READ_ONLY 0x80 /* diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index a9eb6b2..33d8d6f 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -145,6 +145,8 @@ typedef enum TalInstType { * 1 */ ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 * operands, produces 1, N > 0 */ + ASSEM_DICT_GET_DEF, /* 'dict getwithdefault' - consumes N+2 + * operands, produces 1, N > 0 */ ASSEM_DICT_SET, /* specifies key count and LVT index, consumes * N+1 operands, produces 1, N > 0 */ ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes @@ -362,6 +364,7 @@ static const TalInstDesc TalInstructionTable[] = { {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, + {"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,1}, {"dictIncrImm", ASSEM_SINT4_LVT4, INST_DICT_INCR_IMM, 1, 1}, {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, @@ -617,10 +620,14 @@ BBUpdateStackReqs( if (consumed == INT_MIN) { /* - * The instruction is variadic; it consumes 'count' operands. + * The instruction is variadic; it consumes 'count' operands, or + * 'count+1' for ASSEM_DICT_GET_DEF. */ consumed = count; + if (TalInstructionTable[tblIdx].instType == ASSEM_DICT_GET_DEF) { + consumed++; + } } if (produced < 0) { /* @@ -1394,6 +1401,7 @@ AssembleOneLine( break; case ASSEM_DICT_GET: + case ASSEM_DICT_GET_DEF: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e116698..ac32293 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -157,6 +157,7 @@ static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; static Tcl_NRPostProc NRPostInvoke; +static Tcl_ObjCmdProc CoroTypeObjCmd; MODULE_SCOPE const TclStubs tclStubs; @@ -243,6 +244,7 @@ static const CmdInfo builtInCmds[] = { {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, + {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, @@ -936,8 +938,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); @@ -2328,14 +2333,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++; @@ -2355,16 +2362,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). */ Tcl_Free(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 @@ -2546,7 +2552,7 @@ TclCreateObjCommandInNs( } /* - * An existing command conflicts. Try to delete it. + * An existing command conflicts. Try to delete it... */ cmdPtr = Tcl_GetHashValue(hPtr); @@ -4171,15 +4177,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); @@ -4195,14 +4208,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); @@ -4210,10 +4221,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) { @@ -4222,9 +4233,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) { @@ -4235,9 +4245,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++; @@ -4304,12 +4314,10 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { - NRE_callback *callbackPtr; - Tcl_NRPostProc *procPtr; - 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); @@ -4469,7 +4477,7 @@ TEOV_Error( int objc = PTR2INT(data[0]); Tcl_Obj **objv = data[1]; - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){ + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { /* * If there was an error, a command string will be needed for the * error log: get it out of the itemPtr. The details depend on the @@ -4678,7 +4686,7 @@ TEOV_RunLeaveTraces( const char *command = TclGetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } @@ -6377,14 +6385,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); @@ -7625,13 +7636,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; @@ -7985,8 +8004,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); @@ -8437,6 +8458,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. @@ -8667,9 +8757,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 99827c8..91313e2 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -758,7 +758,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 073ed20..67e871f 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2586,7 +2586,7 @@ Tcl_LpopObjCmd( /* Argument objects. */ { int listLen, result; - Tcl_Obj *elemPtr; + Tcl_Obj *elemPtr, *stored; Tcl_Obj *listPtr, **elemPtrs; if (objc < 2) { @@ -2624,6 +2624,7 @@ Tcl_LpopObjCmd( /* * Second, remove the element. + * TclLsetFlat adds a ref count which is handled. */ if (objc == 2) { @@ -2634,6 +2635,7 @@ Tcl_LpopObjCmd( if (result != TCL_OK) { return result; } + Tcl_IncrRefCount(listPtr); } else { listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); @@ -2642,8 +2644,9 @@ Tcl_LpopObjCmd( } } - listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); - if (listPtr == NULL) { + stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(listPtr); + if (stored == NULL) { return TCL_ERROR; } @@ -2707,6 +2710,140 @@ Tcl_LrangeObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_LremoveObjCmd -- + * + * This procedure is invoked to process the "lremove" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +LremoveIndexCompare( + const void *el1Ptr, + const void *el2Ptr) +{ + size_t idx1 = *((const size_t *) el1Ptr); + size_t idx2 = *((const size_t *) el2Ptr); + + /* + * This will put the larger element first. + */ + + return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0; +} + +int +Tcl_LremoveObjCmd( + ClientData notUsed, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int i, idxc, listLen, prevIdx, first, num; + size_t *idxv; + Tcl_Obj *listObj; + + /* + * Parse the arguments. + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); + return TCL_ERROR; + } + + listObj = objv[1]; + if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) { + return TCL_ERROR; + } + + idxc = objc - 2; + if (idxc == 0) { + Tcl_SetObjResult(interp, listObj); + return TCL_OK; + } + idxv = Tcl_Alloc((objc - 2) * sizeof(size_t)); + for (i = 2; i < objc; i++) { + if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, + &idxv[i - 2]) != TCL_OK) { + Tcl_Free(idxv); + return TCL_ERROR; + } + } + + /* + * Sort the indices, large to small so that when we remove an index we + * don't change the indices still to be processed. + */ + + if (idxc > 1) { + qsort(idxv, idxc, sizeof(size_t), LremoveIndexCompare); + } + + /* + * Make our working copy, then do the actual removes piecemeal. + */ + + if (Tcl_IsShared(listObj)) { + listObj = TclListObjCopy(NULL, listObj); + } + num = 0; + first = listLen; + for (i = 0, prevIdx = -1 ; i < idxc ; i++) { + int idx = idxv[i]; + + /* + * Repeated index and sanity check. + */ + + if (idx == prevIdx) { + continue; + } + prevIdx = idx; + if (idx < 0 || idx >= listLen) { + continue; + } + + /* + * Coalesce adjacent removes to reduce the number of copies. + */ + + if (num == 0) { + num = 1; + first = idx; + } else if (idx + 1 == first) { + num++; + first = idx; + } else { + /* + * Note that this operation can't fail now; we know we have a list + * and we're only ever contracting that list. + */ + + (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); + listLen -= num; + num = 1; + first = idx; + } + } + if (num != 0) { + (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); + } + Tcl_Free(idxv); + Tcl_SetObjResult(interp, listObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LrepeatObjCmd -- * * This procedure is invoked to process the "lrepeat" Tcl command. See @@ -4189,7 +4326,7 @@ Tcl_LsortObjCmd( elementArray = Tcl_Alloc(length * sizeof(SortElement)); - for (i=0; i < length; i++){ + for (i=0; i < length; i++) { idx = groupSize * i + groupOffset; if (indexc) { /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index afbea80..b2e4da9 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1461,6 +1461,63 @@ StringIndexCmd( /* *---------------------------------------------------------------------- * + * StringInsertCmd -- + * + * This procedure is invoked to process the "string insert" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringInsertCmd( + ClientData dummy, /* Not used */ + Tcl_Interp *interp, /* Current interpreter */ + int objc, /* Number of arguments */ + Tcl_Obj *const objv[]) /* Argument objects */ +{ + size_t length; /* String length */ + size_t index; /* Insert index */ + Tcl_Obj *outObj; /* Output object */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string index insertString"); + return TCL_ERROR; + } + + length = Tcl_GetCharLength(objv[1]); + if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) { + return TCL_ERROR; + } + + if (index == TCL_INDEX_NONE) { + index = TCL_INDEX_START; + } + if (index > length) { + index = length; + } + + outObj = TclStringReplace(interp, objv[1], index, 0, objv[3], + TCL_STRING_IN_PLACE); + + if (outObj != NULL) { + Tcl_SetObjResult(interp, outObj); + return TCL_OK; + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * StringIsCmd -- * * This procedure is invoked to process the "string is" Tcl command. See @@ -1956,7 +2013,7 @@ StringMapCmd( */ if (!TclHasStringRep(objv[objc-2]) - && TclHasIntRep(objv[objc-2], &tclDictType)){ + && TclHasIntRep(objv[objc-2], &tclDictType)) { int i, done; Tcl_DictSearch search; @@ -2373,24 +2430,25 @@ StringRplcCmd( end = Tcl_GetCharLength(objv[1]) - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { return TCL_ERROR; } /* - * The following test screens out most empty substrings as - * candidates for replacement. When they are detected, no - * replacement is done, and the result is the original string, + * The following test screens out most empty substrings as candidates for + * replacement. When they are detected, no replacement is done, and the + * result is the original string. */ - if ((last == TCL_INDEX_NONE) || /* Range ends before start of string */ + + if ((last == TCL_INDEX_NONE) || /* Range ends before start of string */ (first + 1 > end + 1) || /* Range begins after end of string */ (last + 1 < first + 1)) { /* Range begins after it starts */ - /* * BUT!!! when (end < 0) -- an empty original string -- we can * have (first <= end < 0 <= last) and an empty string is permitted * to be replaced. */ + Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; @@ -3280,6 +3338,7 @@ TclInitStringCmd( {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, + {"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0}, {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, @@ -3577,7 +3636,7 @@ TclNRSwitchObjCmd( Tcl_Obj **listv; blist = objv[0]; - if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -4087,11 +4146,12 @@ Tcl_TimeObjCmd( * * This object-based procedure is invoked to process the "timerate" Tcl * command. + * * This is similar to command "time", except the execution limited by * given time (in milliseconds) instead of repetition count. * * Example: - * timerate {after 5} 1000 ; # equivalent for `time {after 5} [expr 1000/5]` + * timerate {after 5} 1000; # equivalent to: time {after 5} [expr 1000/5] * * Results: * A standard Tcl object result. @@ -4109,39 +4169,40 @@ Tcl_TimeRateObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static double measureOverhead = 0; /* global measure-overhead */ + static double measureOverhead = 0; + /* global measure-overhead */ double overhead = -1; /* given measure-overhead */ register Tcl_Obj *objPtr; register int result, i; Tcl_Obj *calibrate = NULL, *direct = NULL; Tcl_WideUInt count = 0; /* Holds repetition count */ - Tcl_WideInt maxms = WIDE_MIN; + Tcl_WideInt maxms = WIDE_MIN; /* Maximal running time (in milliseconds) */ Tcl_WideUInt maxcnt = WIDE_MAX; /* Maximal count of iterations. */ Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster * repeat count without time check) */ - Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max threshold - * additionally avoid divide to zero (never < 1) */ + Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max + * threshold, additionally avoiding divide to + * zero (i.e., never < 1) */ unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid * growth of execution time. */ register Tcl_WideInt start, middle, stop; #ifndef TCL_WIDE_CLICKS Tcl_Time now; -#endif - +#endif /* !TCL_WIDE_CLICKS */ static const char *const options[] = { "-direct", "-overhead", "-calibrate", "--", NULL }; enum options { TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST }; - NRE_callback *rootPtr; - ByteCode *codePtr = NULL; + ByteCode *codePtr = NULL; for (i = 1; i < objc - 1; i++) { - int index; + int index; + if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT, &index) != TCL_OK) { break; @@ -4168,9 +4229,11 @@ Tcl_TimeRateObjCmd( } } - if (i >= objc || i < objc-3) { -usage: - Tcl_WrongNumArgs(interp, 1, objv, "?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"); + if (i >= objc || i < objc - 3) { + usage: + Tcl_WrongNumArgs(interp, 1, objv, + "?-direct? ?-calibrate? ?-overhead double? " + "command ?time ?max-count??"); return TCL_ERROR; } objPtr = objv[i++]; @@ -4181,6 +4244,7 @@ usage: } if (i < objc) { /* max-count*/ Tcl_WideInt v; + result = Tcl_GetWideIntFromObj(interp, objv[i], &v); if (result != TCL_OK) { return result; @@ -4189,10 +4253,15 @@ usage: } } - /* if calibrate */ + /* + * If we are doing calibration. + */ + if (calibrate) { + /* + * If no time specified for the calibration. + */ - /* if no time specified for the calibration */ if (maxms == WIDE_MIN) { Tcl_Obj *clobjv[6]; Tcl_WideInt maxCalTime = 5000; @@ -4201,18 +4270,24 @@ usage: clobjv[0] = objv[0]; i = 1; if (direct) { - clobjv[i++] = direct; + clobjv[i++] = direct; } clobjv[i++] = objPtr; - /* reset last measurement overhead */ - measureOverhead = (double)0; + /* + * Reset last measurement overhead. + */ + + measureOverhead = (double) 0; + + /* + * Self-call with 100 milliseconds to warm-up, before entering the + * calibration cycle. + */ - /* self-call with 100 milliseconds to warm-up, - * before entering the calibration cycle */ TclNewIntObj(clobjv[i], 100); Tcl_IncrRefCount(clobjv[i]); - result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv); + result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); if (result != TCL_OK) { return result; @@ -4222,59 +4297,86 @@ usage: clobjv[i++] = calibrate; clobjv[i++] = objPtr; - /* set last measurement overhead to max */ - measureOverhead = (double)UWIDE_MAX; + /* + * Set last measurement overhead to max. + */ + + measureOverhead = (double) UWIDE_MAX; + + /* + * Run the calibration cycle until it is more precise. + */ - /* calibration cycle until it'll be preciser */ maxms = -1000; do { lastMeasureOverhead = measureOverhead; - TclNewIntObj(clobjv[i], (int)maxms); + TclNewIntObj(clobjv[i], (int) maxms); Tcl_IncrRefCount(clobjv[i]); - result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv); + result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); if (result != TCL_OK) { return result; } maxCalTime += maxms; - /* increase maxms for preciser calibration */ - maxms -= (-maxms / 4); - /* as long as new value more as 0.05% better */ - } while ( (measureOverhead >= lastMeasureOverhead + + /* + * Increase maxms for more precise calibration. + */ + + maxms -= -maxms / 4; + + /* + * As long as new value more as 0.05% better + */ + } while ((measureOverhead >= lastMeasureOverhead || measureOverhead / lastMeasureOverhead <= 0.9995) - && maxCalTime > 0 - ); + && maxCalTime > 0); return result; } if (maxms == 0) { - /* reset last measurement overhead */ + /* + * Reset last measurement overhead + */ + measureOverhead = 0; Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); return TCL_OK; } - /* if time is negative - make current overhead more precise */ + /* + * If time is negative, make current overhead more precise. + */ + if (maxms > 0) { - /* set last measurement overhead to max */ - measureOverhead = (double)UWIDE_MAX; + /* + * Set last measurement overhead to max. + */ + + measureOverhead = (double) UWIDE_MAX; } else { maxms = -maxms; } - } if (maxms == WIDE_MIN) { - maxms = 1000; + maxms = 1000; } if (overhead == -1) { overhead = measureOverhead; } - /* be sure that resetting of result will not smudge the further measurement */ + /* + * Ensure that resetting of result will not smudge the further + * measurement. + */ + Tcl_ResetResult(interp); - /* compile object */ + /* + * Compile object if needed. + */ + if (!direct) { if (TclInterpReady(interp) != TCL_OK) { return TCL_ERROR; @@ -4283,158 +4385,258 @@ usage: TclPreserveByteCode(codePtr); } - /* get start and stop time */ + /* + * Get start and stop time. + */ + #ifdef TCL_WIDE_CLICKS start = middle = TclpGetWideClicks(); - /* time to stop execution (in wide clicks) */ + + /* + * Time to stop execution (in wide clicks). + */ + stop = start + (maxms * 1000 / TclpWideClickInMicrosec()); #else Tcl_GetTime(&now); - start = now.sec; start *= 1000000; start += now.usec; + start = now.sec; + start *= 1000000; + start += now.usec; middle = start; - /* time to stop execution (in microsecs) */ + + /* + * Time to stop execution (in microsecs). + */ + stop = start + maxms * 1000; -#endif +#endif /* TCL_WIDE_CLICKS */ - /* start measurement */ - if (maxcnt > 0) - while (1) { - /* eval single iteration */ - count++; - - if (!direct) { - /* precompiled */ - rootPtr = TOP_CB(interp); - result = TclNRExecuteByteCode(interp, codePtr); - result = TclNRRunCallbacks(interp, result, rootPtr); - } else { - /* eval */ - result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); - } - if (result != TCL_OK) { - /* allow break from measurement cycle (used for conditional stop) */ - if (result != TCL_BREAK) { - goto done; + /* + * Start measurement. + */ + + if (maxcnt > 0) { + while (1) { + /* + * Evaluate a single iteration. + */ + + count++; + if (!direct) { /* precompiled */ + rootPtr = TOP_CB(interp); + result = TclNRExecuteByteCode(interp, codePtr); + result = TclNRRunCallbacks(interp, result, rootPtr); + } else { /* eval */ + result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); } - /* force stop immediately */ - threshold = 1; - maxcnt = 0; - result = TCL_OK; - } - - /* don't check time up to threshold */ - if (--threshold > 0) continue; - - /* check stop time reached, estimate new threshold */ - #ifdef TCL_WIDE_CLICKS - middle = TclpGetWideClicks(); - #else - Tcl_GetTime(&now); - middle = now.sec; middle *= 1000000; middle += now.usec; - #endif - if (middle >= stop || count >= maxcnt) { - break; - } + if (result != TCL_OK) { + /* + * Allow break from measurement cycle (used for conditional + * stop). + */ - /* don't calculate threshold by few iterations, because sometimes first - * iteration(s) can be too fast or slow (cached, delayed clean up, etc) */ - if (count < 10) { - threshold = 1; continue; - } + if (result != TCL_BREAK) { + goto done; + } - /* average iteration time in microsecs */ - threshold = (middle - start) / count; - if (threshold > maxIterTm) { - maxIterTm = threshold; - /* interations seems to be longer */ - if (threshold > (maxIterTm * 2)) { - if ((factor *= 2) > 50) factor = 50; - } else { - if (factor < 50) factor++; + /* + * Force stop immediately. + */ + + threshold = 1; + maxcnt = 0; + result = TCL_OK; } - } else if (factor > 4) { - /* interations seems to be shorter */ - if (threshold < (maxIterTm / 2)) { - if ((factor /= 2) < 4) factor = 4; - } else { - factor--; + + /* + * Don't check time up to threshold. + */ + + if (--threshold > 0) { + continue; + } + + /* + * Check stop time reached, estimate new threshold. + */ + +#ifdef TCL_WIDE_CLICKS + middle = TclpGetWideClicks(); +#else + Tcl_GetTime(&now); + middle = now.sec; + middle *= 1000000; + middle += now.usec; +#endif /* TCL_WIDE_CLICKS */ + + if (middle >= stop || count >= maxcnt) { + break; + } + + /* + * Don't calculate threshold by few iterations, because sometimes + * first iteration(s) can be too fast or slow (cached, delayed + * clean up, etc). + */ + + if (count < 10) { + threshold = 1; + continue; + } + + /* + * Average iteration time in microsecs. + */ + + threshold = (middle - start) / count; + if (threshold > maxIterTm) { + maxIterTm = threshold; + + /* + * Iterations seem to be longer. + */ + + if (threshold > maxIterTm * 2) { + factor *= 2; + if (factor > 50) { + factor = 50; + } + } else { + if (factor < 50) { + factor++; + } + } + } else if (factor > 4) { + /* + * Iterations seem to be shorter. + */ + + if (threshold < (maxIterTm / 2)) { + factor /= 2; + if (factor < 4) { + factor = 4; + } + } else { + factor--; + } + } + + /* + * As relation between remaining time and time since last check, + * maximal some % of time (by factor), so avoid growing of the + * execution time if iterations are not consistent, e.g. was + * continuously on time). + */ + + threshold = ((stop - middle) / maxIterTm) / factor + 1; + if (threshold > 100000) { /* fix for too large threshold */ + threshold = 100000; + } + + /* + * Consider max-count + */ + + if (threshold > maxcnt - count) { + threshold = maxcnt - count; } - } - /* as relation between remaining time and time since last check, - * maximal some % of time (by factor), so avoid growing of the execution time - * if iterations are not consistent, e. g. wax continuously on time) */ - threshold = ((stop - middle) / maxIterTm) / factor + 1; - if (threshold > 100000) { /* fix for too large threshold */ - threshold = 100000; - } - /* consider max-count */ - if (threshold > maxcnt - count) { - threshold = maxcnt - count; } } { Tcl_Obj *objarr[8], **objs = objarr; Tcl_WideInt val; - const char *fmt; + int digits; - middle -= start; /* execution time in microsecs */ + middle -= start; /* execution time in microsecs */ + +#ifdef TCL_WIDE_CLICKS + /* + * convert execution time in wide clicks to microsecs. + */ - #ifdef TCL_WIDE_CLICKS - /* convert execution time in wide clicks to microsecs */ middle *= TclpWideClickInMicrosec(); - #endif +#endif /* TCL_WIDE_CLICKS */ - if (!count) { /* no iterations - avoid divide by zero */ + if (!count) { /* no iterations - avoid divide by zero */ objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0); goto retRes; } - /* if not calibrate */ + /* + * If not calibrating... + */ + if (!calibrate) { - /* minimize influence of measurement overhead */ + /* + * Minimize influence of measurement overhead. + */ + if (overhead > 0) { - /* estimate the time of overhead (microsecs) */ + /* + * Estimate the time of overhead (microsecs). + */ + Tcl_WideUInt curOverhead = overhead * count; - if (middle > (Tcl_WideInt)curOverhead) { + + if (middle > (Tcl_WideInt) curOverhead) { middle -= curOverhead; } else { middle = 0; } } } else { - /* calibration - obtaining new measurement overhead */ - if (measureOverhead > (double)middle / count) { - measureOverhead = (double)middle / count; + /* + * Calibration: obtaining new measurement overhead. + */ + + if (measureOverhead > ((double) middle) / count) { + measureOverhead = ((double) middle) / count; } objs[0] = Tcl_NewDoubleObj(measureOverhead); TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */ objs += 2; } - val = middle / count; /* microsecs per iteration */ + val = middle / count; /* microsecs per iteration */ if (val >= 1000000) { objs[0] = Tcl_NewWideIntObj(val); } else { - if (val < 10) { fmt = "%.6f"; } else - if (val < 100) { fmt = "%.4f"; } else - if (val < 1000) { fmt = "%.3f"; } else - if (val < 10000) { fmt = "%.2f"; } else - { fmt = "%.1f"; }; - objs[0] = Tcl_ObjPrintf(fmt, ((double)middle)/count); + if (val < 10) { + digits = 6; + } else if (val < 100) { + digits = 4; + } else if (val < 1000) { + digits = 3; + } else if (val < 10000) { + digits = 2; + } else { + digits = 1; + } + objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) middle)/count); } objs[2] = Tcl_NewWideIntObj(count); /* iterations */ - /* calculate speed as rate (count) per sec */ - if (!middle) middle++; /* +1 ms, just to avoid divide by zero */ + /* + * Calculate speed as rate (count) per sec + */ + + if (!middle) { + middle++; /* Avoid divide by zero. */ + } if (count < (WIDE_MAX / 1000000)) { val = (count * 1000000) / middle; if (val < 100000) { - if (val < 100) { fmt = "%.3f"; } else - if (val < 1000) { fmt = "%.2f"; } else - { fmt = "%.1f"; }; - objs[4] = Tcl_ObjPrintf(fmt, ((double)(count * 1000000)) / middle); + if (val < 100) { + digits = 3; + } else if (val < 1000) { + digits = 2; + } else { + digits = 1; + } + objs[4] = Tcl_ObjPrintf("%.*f", + digits, ((double) (count * 1000000)) / middle); } else { objs[4] = Tcl_NewWideIntObj(val); } @@ -4443,7 +4645,10 @@ usage: } retRes: - /* estimated net execution time (in millisecs) */ + /* + * Estimated net execution time (in millisecs). + */ + if (!calibrate) { if (middle >= 1) { objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000); @@ -4454,9 +4659,9 @@ usage: } /* - * Construct the result as a list because many programs have always parsed - * as such (extracting the first element, typically). - */ + * Construct the result as a list because many programs have always + * parsed as such (extracting the first element, typically). + */ TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */ TclNewLiteralStringObj(objs[3], "#"); @@ -4464,12 +4669,10 @@ usage: Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr)); } -done: - + done: if (codePtr != NULL) { TclReleaseByteCode(codePtr); } - return result; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6ec0e26..afe16b2 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1179,6 +1179,38 @@ TclCompileDictGetCmd( } int +TclCompileDictGetWithDefaultCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int i; + DefineLineInformation; /* TIP #280 */ + + /* + * There must be at least three arguments after the command. + */ + + /* TODO: Consider support for compiling expanded args. */ + if (parsePtr->numWords < 4) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + + for (i=1 ; i<parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); + TclAdjustStackDepth(-2, envPtr); + return TCL_OK; +} + +int TclCompileDictExistsCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 3e72854..f5aa295 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -434,7 +434,7 @@ TclCompileIfCmd( jumpFalseDist += 3; TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%u\" updating ifFalse jump", opCode); + Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode); } } } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 4586992..58d926d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -449,6 +449,63 @@ TclCompileStringIndexCmd( } int +TclCompileStringInsertCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + int idx; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + + /* Compute and push the string in which to insert */ + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* See what can be discovered about index at compile time */ + tokenPtr = TokenAfter(tokenPtr); + if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, + TCL_INDEX_END, &idx)) { + + /* Nothing useful knowable - cease compile; let it direct eval */ + return TCL_OK; + } + + /* Compute and push the string to be inserted */ + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + + if (idx == (int)TCL_INDEX_START) { + /* Prepend the insertion string */ + OP4( REVERSE, 2); + OP1( STR_CONCAT1, 2); + } else if (idx == (int)TCL_INDEX_END) { + /* Append the insertion string */ + OP1( STR_CONCAT1, 2); + } else { + /* Prefix + insertion + suffix */ + if (idx < (int)TCL_INDEX_END) { + /* See comments in compiler for [linsert]. */ + idx++; + } + OP4( OVER, 1); + OP44( STR_RANGE_IMM, 0, idx-1); + OP4( REVERSE, 3); + OP44( STR_RANGE_IMM, idx, TCL_INDEX_END); + OP1( STR_CONCAT1, 3); + } + + return TCL_OK; +} + +int TclCompileStringIsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 019b5b1..0851bc1 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -641,6 +641,14 @@ InstructionDesc const tclInstructionTable[] = { * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds. * Stack: ... => ... time */ + {"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* The top word is the default, the next op4 words (min 1) are a key + * path into the dictionary just below the keys on the stack, and all + * those values are replaced by the value read out of that key-path + * (like [dict get]) except if there is no such key, when instead the + * default is pushed instead. + * Stack: ... dict key1 ... keyN default => ... value */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -678,7 +686,7 @@ static void StartExpanding(CompileEnv *envPtr); */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, - size_t numWords, int line, int *clNext, int **lines, + int numWords, int line, int *clNext, int **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); @@ -3239,7 +3247,7 @@ EnterCmdWordData( int srcOffset, /* Offset of first char of the command. */ Tcl_Token *tokenPtr, const char *cmd, - size_t numWords, + int numWords, int line, int *clNext, int **wlines, @@ -3247,8 +3255,7 @@ EnterCmdWordData( { ECL *ePtr; const char *last; - size_t wordIdx; - int wordLine, *wwlines, *wordNext; + int wordIdx, wordLine, *wwlines, *wordNext; if (eclPtr->nuloc >= eclPtr->nloc) { /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 614215c..35759ea 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -541,7 +541,6 @@ typedef struct ByteCode { */ enum TclInstruction { - /* Opcodes 0 to 9 */ INST_DONE = 0, INST_PUSH1, @@ -818,10 +817,11 @@ enum TclInstruction { INST_CLOCK_READ, + INST_DICT_GET_DEF, + /* The last opcode */ LAST_INST_OPCODE }; - /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 002d365..43ff742 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -515,8 +515,7 @@ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); -/* 174 */ -EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp); +/* Slot 174 is reserved */ /* Slot 175 is reserved */ /* 176 */ EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, @@ -545,7 +544,7 @@ EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, - char *addr, int type); + void *addr, int type); /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode); @@ -1750,6 +1749,10 @@ EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr); EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr); /* 643 */ EXTERN int Tcl_IsShared(Tcl_Obj *objPtr); +/* 644 */ +EXTERN int Tcl_LinkArray(Tcl_Interp *interp, + const char *varName, void *addr, int type, + int size); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -1959,7 +1962,7 @@ typedef struct TclStubs { int (*tcl_GetServiceMode) (void); /* 171 */ Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ - const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ + void (*reserved174)(void); void (*reserved175)(void); const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ void (*reserved177)(void); @@ -1972,7 +1975,7 @@ typedef struct TclStubs { int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */ int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ - int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */ + int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ @@ -2429,6 +2432,7 @@ typedef struct TclStubs { void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ + int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -2791,8 +2795,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetSlave) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ -#define Tcl_GetStringResult \ - (tclStubsPtr->tcl_GetStringResult) /* 174 */ +/* Slot 174 is reserved */ /* Slot 175 is reserved */ #define Tcl_GetVar2 \ (tclStubsPtr->tcl_GetVar2) /* 176 */ @@ -3694,6 +3697,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ +#define Tcl_LinkArray \ + (tclStubsPtr->tcl_LinkArray) /* 644 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3701,11 +3706,9 @@ extern const TclStubs *tclStubsPtr; #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp -# undef Tcl_GetStringResult # undef Tcl_Init # undef Tcl_ObjSetVar2 # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) -# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) # define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) @@ -3759,6 +3762,7 @@ extern const TclStubs *tclStubsPtr; Tcl_EvalEx(interp, objPtr, -1, 0) #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) +#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) #define Tcl_SaveResult(interp, statePtr) \ do { \ *(statePtr) = Tcl_GetObjResult(interp); \ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 6bdbfa6..84e8ed4 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -34,6 +34,8 @@ static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static int DictGetDefCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, @@ -89,6 +91,9 @@ static const EnsembleImplMap implementationMap[] = { {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, + {"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0}, + {"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, + NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, @@ -1618,6 +1623,71 @@ DictGetCmd( /* *---------------------------------------------------------------------- * + * DictGetDefCmd -- + * + * This function implements the "dict getdef" and "dict getwithdefault" + * Tcl commands. See the user documentation for details on what it does, + * and TIP#342 for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictGetDefCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr; + Tcl_Obj *const *keyPath; + int numKeys; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key default"); + return TCL_ERROR; + } + + /* + * Give the bits of arguments names for clarity. + */ + + dictPtr = objv[1]; + keyPath = &objv[2]; + numKeys = objc - 4; /* Number of keys in keyPath; there's always + * one extra key afterwards too. */ + keyPtr = objv[objc - 2]; + defaultPtr = objv[objc - 1]; + + /* + * Implement the getting-with-default operation. + */ + + dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath, + DICT_PATH_EXISTS); + if (dictPtr == NULL) { + return TCL_ERROR; + } else if (dictPtr == DICT_PATH_NON_EXISTENT) { + Tcl_SetObjResult(interp, defaultPtr); + } else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) { + return TCL_ERROR; + } else if (valuePtr == NULL) { + Tcl_SetObjResult(interp, defaultPtr); + } else { + Tcl_SetObjResult(interp, valuePtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * DictReplaceCmd -- * * This function implements the "dict replace" Tcl command. See the user @@ -2007,11 +2077,9 @@ DictExistsCmd( return TCL_ERROR; } - dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2, - DICT_PATH_EXISTS); - if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT - || Tcl_DictObjGet(interp, dictPtr, objv[objc-1], - &valuePtr) != TCL_OK) { + dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2,DICT_PATH_EXISTS); + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT || + Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8dd7a6d..18b1fa6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5423,7 +5423,7 @@ TEBCresume( /* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */ Tcl_WideInt w; - if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { + if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { type1 = TCL_NUMBER_INT; } } @@ -6397,55 +6397,23 @@ TEBCresume( TRACE_APPEND(("OK\n")); NEXT_INST_F(1, 1, 0); - case INST_DICT_GET: case INST_DICT_EXISTS: { - Tcl_Interp *interp2 = interp; int found; opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); - if (*pc == INST_DICT_EXISTS) { - interp2 = NULL; - } if (opnd > 1) { - dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); - if (dictPtr == NULL) { - if (*pc == INST_DICT_EXISTS) { - found = 0; - goto afterDictExists; - } - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); - goto gotError; + dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS); + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) { + found = 0; + goto afterDictExists; } } - if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, + if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { - if (*pc == INST_DICT_EXISTS) { - found = (objResultPtr ? 1 : 0); - goto afterDictExists; - } - if (!objResultPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } else if (*pc != INST_DICT_EXISTS) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; + found = (objResultPtr ? 1 : 0); } else { found = 0; } @@ -6461,6 +6429,68 @@ TEBCresume( JUMP_PEEPHOLE_V(found, 5, opnd+1); } + case INST_DICT_GET: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = OBJ_AT_DEPTH(opnd); + if (opnd > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); + if (dictPtr == NULL) { + TRACE_WITH_OBJ(( + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd))), + Tcl_GetObjResult(interp)); + goto gotError; + } + } + if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, + &objResultPtr) != TCL_OK) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + if (!objResultPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + case INST_DICT_GET_DEF: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = OBJ_AT_DEPTH(opnd+1); + if (opnd > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS); + if (dictPtr == NULL) { + TRACE_WITH_OBJ(( + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd+1))), + Tcl_GetObjResult(interp)); + goto gotError; + } else if (dictPtr == DICT_PATH_NON_EXISTENT) { + goto dictGetDefUseDefault; + } + } + if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, + &objResultPtr) != TCL_OK) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } else if (!objResultPtr) { + dictGetDefUseDefault: + objResultPtr = OBJ_AT_TOS; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+2, 1); case INST_DICT_SET: case INST_DICT_UNSET: @@ -7978,7 +8008,7 @@ ExecuteExtendedBinaryMathOp( * Reduce small powers of 2 to shifts. */ - if ((Tcl_WideUInt)w2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + if ((Tcl_WideUInt) w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) { WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); } goto overflowExpon; @@ -8029,22 +8059,18 @@ ExecuteExtendedBinaryMathOp( } overflowExpon: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((big2.used > 1) -#if DIGIT_BIT > 28 - || ((big2.used == 1) && (big2.dp[0] >= (1<<28))) -#endif - ) { - mp_clear(&big2); + + if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK) + || (value2Ptr->typePtr != &tclIntType) + || (Tcl_WideUInt)w2 >= (1<<28)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); mp_init(&bigResult); - mp_expt_d_ex(&big1, big2.dp[0], &bigResult, 1); + mp_expt_d_ex(&big1, w2, &bigResult, 1); mp_clear(&big1); - mp_clear(&big2); BIG_RESULT(&bigResult); } diff --git a/generic/tclIO.c b/generic/tclIO.c index 6a80363..9d15ff5 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. */ @@ -4448,6 +4453,8 @@ Write( } } + UpdateInterest(chanPtr); + return total; } @@ -8479,9 +8486,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. @@ -8507,6 +8514,16 @@ UpdateInterest( } } } + + if (!statePtr->timer + && mask & TCL_WRITABLE + && GotFlag(statePtr, CHANNEL_NONBLOCKING)) { + + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc,chanPtr); + } + + ChanWatch(chanPtr, mask); } @@ -8535,6 +8552,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) @@ -8546,13 +8578,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 31bc8e0..f356184 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -54,6 +54,8 @@ static int ReflectGetOption(ClientData clientData, static int ReflectSetOption(ClientData clientData, Tcl_Interp *interp, const char *optionName, const char *newValue); +static void TimerRunRead(ClientData clientData); +static void TimerRunWrite(ClientData clientData); /* * The C layer channel type/driver definition used by the reflection. This is @@ -112,6 +114,17 @@ typedef struct { int dead; /* Boolean signal that some operations * should no longer be attempted. */ + Tcl_TimerToken readTimer; /* + A token for the timer that is scheduled in + order to call Tcl_NotifyChannel when the + channel is readable + */ + Tcl_TimerToken writeTimer; /* + A token for the timer that is scheduled in + order to call Tcl_NotifyChannel when the + channel is writable + */ + /* * Note regarding the usage of timers. * @@ -121,11 +134,9 @@ typedef struct { * * See 'rechan', 'memchan', etc. * - * Here this is _not_ required. Interest in events is posted to the Tcl - * level via 'watch'. And posting of events is possible from the Tcl level - * as well, via 'chan postevent'. This means that the generation of all - * events, fake or not, timer based or not, is completely in the hands of - * the Tcl level. Therefore no timer here. + * A timer is used here as well in order to ensure at least on pass through + * the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and + * ef28eb1f1516. */ } ReflectedChannel; @@ -920,7 +931,18 @@ TclChanPostEventObjCmd( #if TCL_THREADS if (rcPtr->owner == rcPtr->thread) { #endif - Tcl_NotifyChannel(chan, events); + if (events & TCL_READABLE) { + if (rcPtr->readTimer == NULL) { + rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + TimerRunRead, rcPtr); + } + } + if (events & TCL_WRITABLE) { + if (rcPtr->writeTimer == NULL) { + rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + TimerRunWrite, rcPtr); + } + } #if TCL_THREADS } else { ReflectEvent *ev = Tcl_Alloc(sizeof(ReflectEvent)); @@ -968,6 +990,24 @@ TclChanPostEventObjCmd( #undef EVENT } +static void +TimerRunRead( + ClientData clientData) +{ + ReflectedChannel *rcPtr = clientData; + rcPtr->readTimer = NULL; + Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE); +} + +static void +TimerRunWrite( + ClientData clientData) +{ + ReflectedChannel *rcPtr = clientData; + rcPtr->writeTimer = NULL; + Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE); +} + /* * Channel error message marshalling utilities. */ @@ -1161,6 +1201,12 @@ ReflectClose( Tcl_Free((void *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } + if (rcPtr->readTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->readTimer); + } + if (rcPtr->writeTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->writeTimer); + } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1230,6 +1276,12 @@ ReflectClose( Tcl_Free((void *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } + if (rcPtr->readTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->readTimer); + } + if (rcPtr->writeTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->writeTimer); + } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return (result == TCL_OK) ? EOK : EINVAL; } @@ -2131,6 +2183,8 @@ NewReflectedChannel( rcPtr->chan = NULL; rcPtr->interp = interp; rcPtr->dead = 0; + rcPtr->readTimer = 0; + rcPtr->writeTimer = 0; #if TCL_THREADS rcPtr->thread = Tcl_GetCurrentThread(); #endif diff --git a/generic/tclInt.h b/generic/tclInt.h index e815119..2538498 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3034,6 +3034,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); @@ -3395,6 +3396,9 @@ MODULE_SCOPE int Tcl_LpopObjCmd(void *clientData, MODULE_SCOPE int Tcl_LrangeObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LremoveObjCmd(void *clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrepeatObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3569,6 +3573,9 @@ MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictGetWithDefaultCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3731,6 +3738,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringInsertCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -4465,6 +4475,31 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------- + * Macro used by the Tcl core to get the bignum out of the bignum + * representation of a Tcl_Obj. + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum); + *---------------------------------------------------------------- + */ + +#define TclUnpackBignum(objPtr, bignum) \ + do { \ + register Tcl_Obj *bignumObj = (objPtr); \ + register int bignumPayload = \ + PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \ + if (bignumPayload == -1) { \ + (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \ + } else { \ + (bignum).dp = bignumObj->internalRep.twoPtrValue.ptr1; \ + (bignum).sign = bignumPayload >> 30; \ + (bignum).alloc = (bignumPayload >> 15) & 0x7fff; \ + (bignum).used = bignumPayload & 0x7fff; \ + } \ + } while (0) + +/* + *---------------------------------------------------------------- * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C * "prototype" for this macro is: diff --git a/generic/tclLink.c b/generic/tclLink.c index c4b08ed..1352b6f 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -8,12 +8,16 @@ * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2008 Rene Zaumseil + * Copyright (c) 2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" +#include "tommath.h" +#include <math.h> /* * For each linked variable there is a data structure of the following type, @@ -23,11 +27,17 @@ typedef struct { 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 * via upvar. */ - char *addr; /* Location of C variable. */ + void *addr; /* Location of C variable. */ + int bytes; /* Size of C variable array. This is 0 when + * single variables, and >0 used for array + * variables. */ + int numElems; /* Number of elements in C variable array. + * Zero for single variables. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { char c; @@ -44,6 +54,19 @@ typedef struct { Tcl_WideUInt uw; float f; double d; + void *aryPtr; /* Generic array. */ + char *cPtr; /* char array */ + unsigned char *ucPtr; /* unsigned char array */ + short *sPtr; /* short array */ + unsigned short *usPtr; /* unsigned short array */ + int *iPtr; /* int array */ + unsigned int *uiPtr; /* unsigned int array */ + long *lPtr; /* long array */ + unsigned long *ulPtr; /* unsigned long array */ + Tcl_WideInt *wPtr; /* wide (long long) array */ + Tcl_WideUInt *uwPtr; /* unsigned wide (long long) array */ + float *fPtr; /* float array */ + double *dPtr; /* double array */ } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below for @@ -57,10 +80,16 @@ typedef struct { * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is * in progress for this variable, so trace * callbacks on the variable should be ignored. + * LINK_ALLOC_ADDR - 1 means linkPtr->addr was allocated on the + * heap. + * LINK_ALLOC_LAST - 1 means linkPtr->valueLast.p was allocated on + * the heap. */ #define LINK_READ_ONLY 1 #define LINK_BEING_UPDATED 2 +#define LINK_ALLOC_ADDR 4 +#define LINK_ALLOC_LAST 8 /* * Forward references to functions defined later in this file: @@ -69,9 +98,24 @@ typedef struct { static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); +static void LinkFree(Link *linkPtr); static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); -static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr); -static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); +static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, + double *doublePtr); +static int SetInvalidRealFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); + +/* + * A marker type used to flag weirdnesses so we can pass them around right. + */ + +static Tcl_ObjType invalidRealType = { + "invalidReal", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; /* * Convenience macro for accessing the value of the C variable pointed to by a @@ -108,13 +152,15 @@ int Tcl_LinkVar( Tcl_Interp *interp, /* Interpreter in which varName exists. */ const char *varName, /* Name of a global variable in interp. */ - char *addr, /* Address of a C variable to be linked to + void *addr, /* Address of a C variable to be linked to * varName. */ int type) /* Type of C variable: TCL_LINK_INT, etc. Also * may have TCL_LINK_READ_ONLY OR'ed in. */ { Tcl_Obj *objPtr; Link *linkPtr; + Namespace *dummy; + const char *name; int code; linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, @@ -127,6 +173,7 @@ Tcl_LinkVar( linkPtr = Tcl_Alloc(sizeof(Link)); linkPtr->interp = interp; + linkPtr->nsPtr = NULL; linkPtr->varName = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; @@ -144,19 +191,207 @@ Tcl_LinkVar( } else { linkPtr->flags = 0; } + linkPtr->bytes = 0; + linkPtr->numElems = 0; + objPtr = ObjValue(linkPtr); + if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(linkPtr->varName); + 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); + if (code != TCL_OK) { + Tcl_DecrRefCount(linkPtr->varName); + LinkFree(linkPtr); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinkArray -- + * + * Link a C variable array to a Tcl variable so that changes to either + * one causes the other to change. + * + * Results: + * The return value is TCL_OK if everything went well or TCL_ERROR if an + * error occurred (the interp's result is also set after errors). + * + * Side effects: + * The value at *addr is linked to the Tcl variable "varName", using + * "type" to convert between string values for Tcl and binary values for + * *addr. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LinkArray( + Tcl_Interp *interp, /* Interpreter in which varName exists. */ + const char *varName, /* Name of a global variable in interp. */ + void *addr, /* Address of a C variable to be linked to + * varName. If NULL then the necessary space + * will be allocated and returned as the + * interpreter result. */ + int type, /* Type of C variable: TCL_LINK_INT, etc. Also + * may have TCL_LINK_READ_ONLY OR'ed in. */ + int size) /* Size of C variable array, >1 if array */ +{ + Tcl_Obj *objPtr; + Link *linkPtr; + Namespace *dummy; + const char *name; + int code; + + if (size < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong array size given", -1)); + return TCL_ERROR; + } + + linkPtr = Tcl_Alloc(sizeof(Link)); + linkPtr->type = type & ~TCL_LINK_READ_ONLY; + linkPtr->numElems = size; + if (type & TCL_LINK_READ_ONLY) { + linkPtr->flags = LINK_READ_ONLY; + } else { + linkPtr->flags = 0; + } + + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + linkPtr->bytes = size * sizeof(int); + break; + case TCL_LINK_DOUBLE: + linkPtr->bytes = size * sizeof(double); + break; + case TCL_LINK_WIDE_INT: + linkPtr->bytes = size * sizeof(Tcl_WideInt); + break; + case TCL_LINK_WIDE_UINT: + linkPtr->bytes = size * sizeof(Tcl_WideUInt); + break; + case TCL_LINK_CHAR: + linkPtr->bytes = size * sizeof(char); + break; + case TCL_LINK_UCHAR: + linkPtr->bytes = size * sizeof(unsigned char); + break; + case TCL_LINK_SHORT: + linkPtr->bytes = size * sizeof(short); + break; + case TCL_LINK_USHORT: + linkPtr->bytes = size * sizeof(unsigned short); + break; + case TCL_LINK_UINT: + linkPtr->bytes = size * sizeof(unsigned int); + break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) + case TCL_LINK_LONG: + linkPtr->bytes = size * sizeof(long); + break; + case TCL_LINK_ULONG: + linkPtr->bytes = size * sizeof(unsigned long); + break; +#endif + case TCL_LINK_FLOAT: + linkPtr->bytes = size * sizeof(float); + break; + case TCL_LINK_STRING: + linkPtr->bytes = size * sizeof(char); + size = 1; /* This is a variable length string, no need + * to check last value. */ + + /* + * If no address is given create one and use as address the + * not needed linkPtr->lastValue + */ + + if (addr == NULL) { + linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes); + linkPtr->flags |= LINK_ALLOC_LAST; + addr = (char *) &linkPtr->lastValue.cPtr; + } + break; + case TCL_LINK_CHARS: + case TCL_LINK_BINARY: + linkPtr->bytes = size * sizeof(char); + break; + default: + LinkFree(linkPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad linked array variable type", -1)); + return TCL_ERROR; + } + + /* + * Allocate C variable space in case no address is given + */ + + if (addr == NULL) { + linkPtr->addr = Tcl_Alloc(linkPtr->bytes); + linkPtr->flags |= LINK_ALLOC_ADDR; + } else { + linkPtr->addr = addr; + } + + /* + * If necessary create space for last used value. + */ + + if (size > 1) { + linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes); + linkPtr->flags |= LINK_ALLOC_LAST; + } + + /* + * Initialize allocated space. + */ + + if (linkPtr->flags & LINK_ALLOC_ADDR) { + memset(linkPtr->addr, 0, linkPtr->bytes); + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memset(linkPtr->lastValue.aryPtr, 0, linkPtr->bytes); + } + + /* + * Set common structure values. + */ + + 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) { Tcl_DecrRefCount(linkPtr->varName); - Tcl_Free(linkPtr); + LinkFree(linkPtr); return TCL_ERROR; } + code = Tcl_TraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); - Tcl_Free(linkPtr); + LinkFree(linkPtr); } return code; } @@ -194,7 +429,7 @@ Tcl_UnlinkVar( TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); Tcl_DecrRefCount(linkPtr->varName); - Tcl_Free(linkPtr); + LinkFree(linkPtr); } /* @@ -245,6 +480,242 @@ Tcl_UpdateLinkedVar( /* *---------------------------------------------------------------------- * + * GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial -- + * + * Helper functions for LinkTraceProc and ObjValue. These are all + * factored out here to make those functions simpler. + * + *---------------------------------------------------------------------- + */ + +static inline int +GetInt( + Tcl_Obj *objPtr, + int *intPtr) +{ + return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK + && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK); +} + +static inline int +GetWide( + Tcl_Obj *objPtr, + Tcl_WideInt *widePtr) +{ + if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { + int intValue; + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *widePtr = intValue; + } + return 0; +} + +static inline int +GetUWide( + Tcl_Obj *objPtr, + Tcl_WideUInt *uwidePtr) +{ + Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; + ClientData clientData; + int type, intValue; + + if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { + if (type == TCL_NUMBER_INT) { + *widePtr = *((const Tcl_WideInt *) clientData); + return (*widePtr < 0); + } else if (type == TCL_NUMBER_BIG) { + mp_int *numPtr = clientData; + Tcl_WideUInt value = 0; + union { + Tcl_WideUInt value; + unsigned char bytes[sizeof(Tcl_WideUInt)]; + } scratch; + unsigned long numBytes = sizeof(Tcl_WideUInt); + unsigned char *bytes = scratch.bytes; + + if (numPtr->sign || (MP_OKAY != mp_to_unsigned_bin_n(numPtr, + bytes, &numBytes))) { + /* + * If the sign bit is set (a negative value) or if the value + * can't possibly fit in the bits of an unsigned wide, there's + * no point in doing further conversion. + */ + return 1; + } +#ifdef WORDS_BIGENDIAN + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } +#else /* !WORDS_BIGENDIAN */ + /* + * Little-endian can read the value directly. + */ + value = scratch.value; +#endif /* WORDS_BIGENDIAN */ + *uwidePtr = value; + return 0; + } + } + + /* + * Evil edge case fallback. + */ + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *uwidePtr = intValue; + return 0; +} + +static inline int +GetDouble( + Tcl_Obj *objPtr, + double *dblPtr) +{ + if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) { + return 0; + } else { +#ifdef ACCEPT_NAN + Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType); + + if (irPtr != NULL) { + *dblPtr = irPtr->doubleValue; + return 0; + } +#endif /* ACCEPT_NAN */ + return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; + } +} + +static inline int +EqualDouble( + double a, + double b) +{ + return (a == b) +#ifdef ACCEPT_NAN + || (TclIsNaN(a) && TclIsNaN(b)) +#endif /* ACCEPT_NAN */ + ; +} + +static inline int +IsSpecial( + double a) +{ + return TclIsInfinite(a) +#ifdef ACCEPT_NAN + || TclIsNaN(a) +#endif /* ACCEPT_NAN */ + ; +} + +/* + * Mark an object as holding a weird double. + */ + +static int +SetInvalidRealFromAny( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + size_t length; + const char *str, *endPtr; + + str = TclGetStringFromObj(objPtr, &length); + if ((length == 1) && (str[0] == '.')) { + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = 0.0; + return TCL_OK; + } + if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, + TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { + /* + * If number is followed by [eE][+-]?, then it is an invalid double, + * but it could be the start of a valid double. + */ + + if (*endPtr == 'e' || *endPtr == 'E') { + ++endPtr; + if (*endPtr == '+' || *endPtr == '-') { + ++endPtr; + } + if (*endPtr == 0) { + double doubleValue = 0.0; + + Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); + TclFreeIntRep(objPtr); + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = doubleValue; + return TCL_OK; + } + } + } + return TCL_ERROR; +} + +/* + * This function checks for integer representations, which are valid when + * linking with C variables, but which are invalid in other contexts in Tcl. + * Handled are "+", "-", "", "0x", "0b", "0d" and "0o" (upper- and + * lower-case). See bug [39f6304c2e]. + */ + +static int +GetInvalidIntFromObj( + Tcl_Obj *objPtr, + int *intPtr) +{ + size_t length; + const char *str = TclGetStringFromObj(objPtr, &length); + + if ((length == 0) || + ((length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { + *intPtr = 0; + return TCL_OK; + } else if ((length == 1) && strchr("+-", str[0])) { + *intPtr = (str[0] == '+'); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + * This function checks for double representations, which are valid when + * linking with C variables, but which are invalid in other contexts in Tcl. + * Handled are "+", "-", "", ".", "0x", "0b" and "0o" (upper- and lower-case) + * and sequences like "1e-". See bug [39f6304c2e]. + */ + +static int +GetInvalidDoubleFromObj( + Tcl_Obj *objPtr, + double *doublePtr) +{ + int intValue; + + if (TclHasIntRep(objPtr, &invalidRealType)) { + goto gotdouble; + } + if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { + *doublePtr = (double) intValue; + return TCL_OK; + } + if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { + gotdouble: + *doublePtr = objPtr->internalRep.doubleValue; + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * LinkTraceProc -- * * This function is invoked when a linked Tcl variable is read, written, @@ -273,13 +744,17 @@ LinkTraceProc( { Link *linkPtr = clientData; int changed; - size_t valueLength; + int valueLength; const char *value; char **pp; Tcl_Obj *valueObj; int valueInt; Tcl_WideInt valueWide; + Tcl_WideUInt valueUWide; double valueDouble; + int objc; + Tcl_Obj **objv; + int i; /* * If the variable is being unset, then just re-create it (with a trace) @@ -287,9 +762,9 @@ LinkTraceProc( */ if (flags & TCL_TRACE_UNSETS) { - if (Tcl_InterpDeleted(interp)) { + if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) { Tcl_DecrRefCount(linkPtr->varName); - Tcl_Free(linkPtr); + LinkFree(linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -316,51 +791,64 @@ LinkTraceProc( */ if (flags & TCL_TRACE_READS) { - switch (linkPtr->type) { - case TCL_LINK_INT: - case TCL_LINK_BOOLEAN: - changed = (LinkedVar(int) != linkPtr->lastValue.i); - break; - case TCL_LINK_DOUBLE: - changed = (LinkedVar(double) != linkPtr->lastValue.d); - break; - case TCL_LINK_WIDE_INT: - changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); - break; - case TCL_LINK_WIDE_UINT: - changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); - break; - case TCL_LINK_CHAR: - changed = (LinkedVar(char) != linkPtr->lastValue.c); - break; - case TCL_LINK_UCHAR: - changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); - break; - case TCL_LINK_SHORT: - changed = (LinkedVar(short) != linkPtr->lastValue.s); - break; - case TCL_LINK_USHORT: - changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); - break; - case TCL_LINK_UINT: - changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); - break; + /* + * Variable arrays + */ + + if (linkPtr->flags & LINK_ALLOC_LAST) { + changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr, + linkPtr->bytes); + } else { + /* single variables */ + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = (LinkedVar(int) != linkPtr->lastValue.i); + break; + case TCL_LINK_DOUBLE: + changed = !EqualDouble(LinkedVar(double), linkPtr->lastValue.d); + break; + case TCL_LINK_WIDE_INT: + changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); + break; + case TCL_LINK_WIDE_UINT: + changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); + break; + case TCL_LINK_CHAR: + changed = (LinkedVar(char) != linkPtr->lastValue.c); + break; + case TCL_LINK_UCHAR: + changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); + break; + case TCL_LINK_SHORT: + changed = (LinkedVar(short) != linkPtr->lastValue.s); + break; + case TCL_LINK_USHORT: + changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); + break; + case TCL_LINK_UINT: + changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); + break; #if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) - case TCL_LINK_LONG: - changed = (LinkedVar(long) != linkPtr->lastValue.l); - break; - case TCL_LINK_ULONG: - changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); - break; + case TCL_LINK_LONG: + changed = (LinkedVar(long) != linkPtr->lastValue.l); + break; + case TCL_LINK_ULONG: + changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); + break; #endif - case TCL_LINK_FLOAT: - changed = (LinkedVar(float) != linkPtr->lastValue.f); - break; - case TCL_LINK_STRING: - changed = 1; - break; - default: - return (char *) "internal error: bad linked variable type"; + case TCL_LINK_FLOAT: + changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f); + break; + case TCL_LINK_STRING: + case TCL_LINK_CHARS: + case TCL_LINK_BINARY: + changed = 1; + break; + default: + changed = 0; + /* return (char *) "internal error: bad linked variable type"; */ + } } if (changed) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), @@ -392,169 +880,376 @@ LinkTraceProc( return (char *) "internal error: linked variable couldn't be read"; } + /* + * Special cases. + */ + + switch (linkPtr->type) { + case TCL_LINK_STRING: + value = TclGetStringFromObj(valueObj, &valueLength); + pp = (char **) linkPtr->addr; + + *pp = Tcl_Realloc(*pp, ++valueLength); + memcpy(*pp, value, valueLength); + return NULL; + + case TCL_LINK_CHARS: + value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength); + valueLength++; /* include end of string char */ + if (valueLength > linkPtr->bytes) { + return (char *) "wrong size of char* value"; + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); + memcpy(linkPtr->addr, value, (size_t) valueLength); + } else { + linkPtr->lastValue.c = '\0'; + LinkedVar(char) = linkPtr->lastValue.c; + } + return NULL; + + case TCL_LINK_BINARY: + value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength); + if (valueLength != linkPtr->bytes) { + return (char *) "wrong size of binary value"; + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); + memcpy(linkPtr->addr, value, (size_t) valueLength); + } else { + linkPtr->lastValue.uc = (unsigned char) *value; + LinkedVar(unsigned char) = linkPtr->lastValue.uc; + } + return NULL; + } + + /* + * A helper macro. Writing this as a function is messy because of type + * variance. + */ + +#define InRange(lowerLimit, value, upperLimit) \ + ((value) >= (lowerLimit) && (value) <= (upperLimit)) + + /* + * If we're working with an array of numbers, extract the Tcl list. + */ + + if (linkPtr->flags & LINK_ALLOC_LAST) { + if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR + || objc != linkPtr->numElems) { + return (char *) "wrong dimension"; + } + } + switch (linkPtr->type) { case TCL_LINK_INT: - if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK - && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + int *varPtr = &linkPtr->lastValue.iPtr[i]; + + if (GetInt(objv[i], varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have integer values"; + } + } + } else { + int *varPtr = &linkPtr->lastValue.i; + + if (GetInt(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have integer value"; + } + LinkedVar(int) = *varPtr; } - LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_WIDE_INT: - if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK - && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + Tcl_WideInt *varPtr = &linkPtr->lastValue.wPtr[i]; + + if (GetWide(objv[i], varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have wide integer value"; + } + } + } else { + Tcl_WideInt *varPtr = &linkPtr->lastValue.w; + + if (GetWide(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have wide integer value"; + } + LinkedVar(Tcl_WideInt) = *varPtr; } - LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w; break; case TCL_LINK_DOUBLE: - if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { -#ifdef ACCEPT_NAN - Tcl_ObjIntRep *irPtr = TclFetchIntRep(valueObj, &tclDoubleType); - if (irPtr == NULL) { -#endif - if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have real value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetDouble(objv[i], &linkPtr->lastValue.dPtr[i])) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have real value"; } -#ifdef ACCEPT_NAN } - linkPtr->lastValue.d = irPtr->doubleValue; -#endif + } else { + double *varPtr = &linkPtr->lastValue.d; + + if (GetDouble(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have real value"; + } + LinkedVar(double) = *varPtr; } - LinkedVar(double) = linkPtr->lastValue.d; break; case TCL_LINK_BOOLEAN: - if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have boolean value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + int *varPtr = &linkPtr->lastValue.iPtr[i]; + + if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have boolean value"; + } + } + } else { + int *varPtr = &linkPtr->lastValue.i; + + if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have boolean value"; + } + LinkedVar(int) = *varPtr; } - LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_CHAR: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have char value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have char value"; + } + linkPtr->lastValue.cPtr[i] = (char) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have char value"; + } + LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt; } - LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt; break; case TCL_LINK_UCHAR: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < 0 || valueInt > UCHAR_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned char value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(0, valueInt, UCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned char value"; + } + linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(0, valueInt, UCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned char value"; + } + LinkedVar(unsigned char) = linkPtr->lastValue.uc = + (unsigned char) valueInt; } - LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt; break; case TCL_LINK_SHORT: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have short value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have short value"; + } + linkPtr->lastValue.sPtr[i] = (short) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have short value"; + } + LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt; } - LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt; break; case TCL_LINK_USHORT: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < 0 || valueInt > USHRT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned short value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(0, valueInt, USHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned short value"; + } + linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(0, valueInt, USHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned short value"; + } + LinkedVar(unsigned short) = linkPtr->lastValue.us = + (unsigned short) valueInt; } - LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt; break; case TCL_LINK_UINT: - if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) - || valueWide < 0 || valueWide > UINT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned int value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide) + || !InRange(0, valueWide, UINT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned int value"; + } + linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide; + } + } else { + if (GetWide(valueObj, &valueWide) + || !InRange(0, valueWide, UINT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned int value"; + } + LinkedVar(unsigned int) = linkPtr->lastValue.ui = + (unsigned int) valueWide; } - LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide; break; #if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: - if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) - || valueWide < LONG_MIN || valueWide > LONG_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have long value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide) + || !InRange(LONG_MIN, valueWide, LONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have long value"; + } + linkPtr->lastValue.lPtr[i] = (long) valueWide; + } + } else { + if (GetWide(valueObj, &valueWide) + || !InRange(LONG_MIN, valueWide, LONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have long value"; + } + LinkedVar(long) = linkPtr->lastValue.l = (long) valueWide; } - LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide; break; case TCL_LINK_ULONG: - if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) - || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned long value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetUWide(objv[i], &valueUWide) + || !InRange(0, valueUWide, ULONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned long value"; + } + linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide; + } + } else { + if (GetUWide(valueObj, &valueUWide) + || !InRange(0, valueUWide, ULONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned long value"; + } + LinkedVar(unsigned long) = linkPtr->lastValue.ul = + (unsigned long) valueUWide; } - LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; break; #endif case TCL_LINK_WIDE_UINT: - /* - * FIXME: represent as a bignum. - */ - if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned wide int value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetUWide(objv[i], &valueUWide)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned wide int value"; + } + linkPtr->lastValue.uwPtr[i] = valueUWide; + } + } else { + if (GetUWide(valueObj, &valueUWide)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned wide int value"; + } + LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide; } - LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; break; case TCL_LINK_FLOAT: - if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK - && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK) - || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have float value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetDouble(objv[i], &valueDouble) + && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) + && !IsSpecial(valueDouble)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have float value"; + } + linkPtr->lastValue.fPtr[i] = (float) valueDouble; + } + } else { + if (GetDouble(valueObj, &valueDouble) + && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) + && !IsSpecial(valueDouble)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have float value"; + } + LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble; } - LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble; - break; - - case TCL_LINK_STRING: - value = TclGetStringFromObj(valueObj, &valueLength); - pp = (char **) linkPtr->addr; - - *pp = Tcl_Realloc(*pp, ++valueLength); - memcpy(*pp, value, valueLength); break; default: return (char *) "internal error: bad linked variable type"; } + + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } return NULL; } @@ -581,53 +1276,183 @@ ObjValue( Link *linkPtr) /* Structure describing linked variable. */ { char *p; - Tcl_Obj *resultObj; + Tcl_Obj *resultObj, **objv; + int i; switch (linkPtr->type) { case TCL_LINK_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.iPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewIntObj(linkPtr->lastValue.i); case TCL_LINK_WIDE_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.wPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.w = LinkedVar(Tcl_WideInt); return Tcl_NewWideIntObj(linkPtr->lastValue.w); case TCL_LINK_DOUBLE: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.dPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.d = LinkedVar(double); return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewBooleanObj(linkPtr->lastValue.i); case TCL_LINK_CHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.cPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.c = LinkedVar(char); return Tcl_NewIntObj(linkPtr->lastValue.c); case TCL_LINK_UCHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ucPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.uc = LinkedVar(unsigned char); return Tcl_NewIntObj(linkPtr->lastValue.uc); case TCL_LINK_SHORT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.sPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.s = LinkedVar(short); return Tcl_NewIntObj(linkPtr->lastValue.s); case TCL_LINK_USHORT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.usPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.us = LinkedVar(unsigned short); return Tcl_NewIntObj(linkPtr->lastValue.us); case TCL_LINK_UINT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.uiPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.ui = LinkedVar(unsigned int); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); #if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.lPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.l = LinkedVar(long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); case TCL_LINK_ULONG: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.ulPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); #endif case TCL_LINK_FLOAT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.fPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); case TCL_LINK_WIDE_UINT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) + linkPtr->lastValue.uwPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + Tcl_Free(objv); + return resultObj; + } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); - /* - * FIXME: represent as a bignum. - */ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); + case TCL_LINK_STRING: p = LinkedVar(char *); if (p == NULL) { @@ -636,6 +1461,25 @@ ObjValue( } return Tcl_NewStringObj(p, -1); + case TCL_LINK_CHARS: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0'; + /* take care of proper string end */ + return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes); + } + linkPtr->lastValue.c = '\0'; + return Tcl_NewStringObj(&linkPtr->lastValue.c, 1); + + case TCL_LINK_BINARY: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + return Tcl_NewByteArrayObj((unsigned char *) linkPtr->addr, + linkPtr->bytes); + } + linkPtr->lastValue.uc = LinkedVar(unsigned char); + return Tcl_NewByteArrayObj(&linkPtr->lastValue.uc, 1); + /* * This code only gets executed if the link type is unknown (shouldn't * ever happen). @@ -646,108 +1490,37 @@ ObjValue( return resultObj; } } - -static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); - -static Tcl_ObjType invalidRealType = { - "invalidReal", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ -}; - -static int -SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { - size_t length; - const char *str, *endPtr; - - str = TclGetStringFromObj(objPtr, &length); - if ((length == 1) && (str[0] == '.')){ - objPtr->typePtr = &invalidRealType; - objPtr->internalRep.doubleValue = 0.0; - return TCL_OK; - } - if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, - TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { - /* If number is followed by [eE][+-]?, then it is an invalid - * double, but it could be the start of a valid double. */ - if (*endPtr == 'e' || *endPtr == 'E') { - ++endPtr; - if (*endPtr == '+' || *endPtr == '-') ++endPtr; - if (*endPtr == 0) { - double doubleValue = 0.0; - Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); - TclFreeIntRep(objPtr); - objPtr->typePtr = &invalidRealType; - objPtr->internalRep.doubleValue = doubleValue; - return TCL_OK; - } - } - } - return TCL_ERROR; -} - - + /* - * This function checks for integer representations, which are valid - * when linking with C variables, but which are invalid in other - * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o" - * (upperand lowercase). See bug [39f6304c2e]. + *---------------------------------------------------------------------- + * + * LinkFree -- + * + * Free's allocated space of given link and link structure. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- */ -int -GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr) -{ - size_t length; - const char *str = TclGetStringFromObj(objPtr, &length); - - if ((length == 0) || - ((length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { - *intPtr = 0; - return TCL_OK; - } else if ((length == 1) && strchr("+-", str[0])) { - *intPtr = (str[0] == '+'); - return TCL_OK; - } - return TCL_ERROR; -} - -int -GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) -{ - int intValue; - - if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { - return TCL_ERROR; - } - *widePtr = intValue; - return TCL_OK; -} -/* - * This function checks for double representations, which are valid - * when linking with C variables, but which are invalid in other - * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o" - * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. - */ -int -GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr) +static void +LinkFree( + Link *linkPtr) /* Structure describing linked variable. */ { - int intValue; - - if (TclHasIntRep(objPtr, &invalidRealType)) { - goto gotdouble; + if (linkPtr->nsPtr) { + TclNsDecrRefCount(linkPtr->nsPtr); } - if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { - *doublePtr = (double) intValue; - return TCL_OK; + if (linkPtr->flags & LINK_ALLOC_ADDR) { + Tcl_Free(linkPtr->addr); } - if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { - gotdouble: - *doublePtr = objPtr->internalRep.doubleValue; - return TCL_OK; + if (linkPtr->flags & LINK_ALLOC_LAST) { + Tcl_Free(linkPtr->lastValue.aryPtr); } - return TCL_ERROR; + Tcl_Free(linkPtr); } /* diff --git a/generic/tclListObj.c b/generic/tclListObj.c index df0b21e..023794c 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1092,7 +1092,7 @@ Tcl_ListObjReplace( Tcl_Obj **oldPtrs = elemPtrs; int newMax; - if (needGrow){ + if (needGrow) { newMax = 2 * numRequired; } else { newMax = listRepPtr->maxElemCount; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 3c23b97..426fd16 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 360c7dd..a6a7060 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 11c6e19..df0f435 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 6685f08..f745ff0 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 = Tcl_Realloc(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 = Tcl_Realloc(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/tclObj.c b/generic/tclObj.c index 089945e..42d8fde 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -191,17 +191,6 @@ static Tcl_ThreadDataKey pendingObjDataKey; | ((bignum).alloc << 15) | ((bignum).used)); \ } -#define UNPACK_BIGNUM(objPtr, bignum) \ - if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \ - (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \ - } else { \ - (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \ - (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \ - (bignum).alloc = \ - (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7fff; \ - (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7fff; \ - } - /* * Prototypes for functions defined later in this file: */ @@ -2330,7 +2319,7 @@ Tcl_GetDoubleFromObj( if (objPtr->typePtr == &tclBignumType) { mp_int big; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); *dblPtr = TclBignumToDouble(&big); return TCL_OK; } @@ -2714,7 +2703,7 @@ Tcl_GetLongFromObj( unsigned long scratch, value = 0, numBytes = sizeof(unsigned long); unsigned char *bytes = (unsigned char *) &scratch; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; @@ -2954,7 +2943,7 @@ Tcl_GetWideIntFromObj( Tcl_WideInt scratch; unsigned char *bytes = (unsigned char *) &scratch; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; @@ -3068,7 +3057,7 @@ FreeBignum( { mp_int toFree; /* Bignum to free */ - UNPACK_BIGNUM(objPtr, toFree); + TclUnpackBignum(objPtr, toFree); mp_clear(&toFree); if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { Tcl_Free(objPtr->internalRep.twoPtrValue.ptr1); @@ -3101,7 +3090,7 @@ DupBignum( mp_int bignumCopy; copyPtr->typePtr = &tclBignumType; - UNPACK_BIGNUM(srcPtr, bignumVal); + TclUnpackBignum(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); } @@ -3136,7 +3125,7 @@ UpdateStringOfBignum( int size; char *stringVal; - UNPACK_BIGNUM(objPtr, bignumVal); + TclUnpackBignum(objPtr, bignumVal); if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } @@ -3275,10 +3264,10 @@ GetBignumFromObj( if (copy || Tcl_IsShared(objPtr)) { mp_int temp; - UNPACK_BIGNUM(objPtr, temp); + TclUnpackBignum(objPtr, temp); mp_init_copy(bignumValue, &temp); } else { - UNPACK_BIGNUM(objPtr, *bignumValue); + TclUnpackBignum(objPtr, *bignumValue); /* Optimized TclFreeIntRep */ objPtr->internalRep.twoPtrValue.ptr1 = NULL; objPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -3518,7 +3507,7 @@ TclGetNumberFromObj( static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, sizeof(mp_int)); - UNPACK_BIGNUM(objPtr, *bigPtr); + TclUnpackBignum(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 03fe6cc..2912211 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -38,16 +38,18 @@ typedef struct PkgAvail { } PkgAvail; typedef struct PkgName { - struct PkgName *nextPtr; /* Next in list of package names being initialized. */ + struct PkgName *nextPtr; /* Next in list of package names being + * initialized. */ char name[1]; } PkgName; typedef struct PkgFiles { - PkgName *names; /* Package names being initialized. Must be first field*/ - Tcl_HashTable table; /* Table which contains files for each package */ + PkgName *names; /* Package names being initialized. Must be + * first field. */ + Tcl_HashTable table; /* Table which contains files for each + * package. */ } PkgFiles; - /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the @@ -63,7 +65,7 @@ typedef struct { } Package; typedef struct Require { - void * clientDataPtr; + void *clientDataPtr; const char *name; Package *pkgPtr; char *versionToProvide; @@ -221,8 +223,10 @@ Tcl_PkgProvideEx( *---------------------------------------------------------------------- */ -static void PkgFilesCleanupProc(ClientData clientData, - Tcl_Interp *interp) +static void +PkgFilesCleanupProc( + ClientData clientData, + Tcl_Interp *interp) { PkgFiles *pkgFiles = (PkgFiles *) clientData; Tcl_HashSearch search; @@ -230,12 +234,14 @@ static void PkgFilesCleanupProc(ClientData clientData, while (pkgFiles->names) { PkgName *name = pkgFiles->names; + pkgFiles->names = name->nextPtr; Tcl_Free(name); } entry = Tcl_FirstHashEntry(&pkgFiles->table, &search); while (entry) { Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry); + Tcl_DecrRefCount(obj); entry = Tcl_NextHashEntry(&search); } @@ -244,10 +250,16 @@ static void PkgFilesCleanupProc(ClientData clientData, return; } -void *TclInitPkgFiles(Tcl_Interp *interp) +void * +TclInitPkgFiles( + Tcl_Interp *interp) { - /* If assocdata "tclPkgFiles" doesn't exist yet, create it */ + /* + * If assocdata "tclPkgFiles" doesn't exist yet, create it. + */ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (!pkgFiles) { pkgFiles = Tcl_Alloc(sizeof(PkgFiles)); pkgFiles->names = NULL; @@ -257,9 +269,14 @@ void *TclInitPkgFiles(Tcl_Interp *interp) return pkgFiles; } -void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName) +void +TclPkgFileSeen( + Tcl_Interp *interp, + const char *fileName) { - PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *) + Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (pkgFiles && pkgFiles->names) { const char *name = pkgFiles->names->name; Tcl_HashTable *table = &pkgFiles->table; @@ -347,12 +364,12 @@ Tcl_PkgRequireEx( * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with - * the definition of tclEmptyStringRep near the top of this file. - * It clearly should not have the value NULL; it - * should point to the char tclEmptyString. If we see it having the - * value NULL, then somehow we are seeing a Tcl library that isn't - * completely initialized, and that's an indicator for the error - * condition described above. (Further explanation is welcome.) + * the definition of tclEmptyStringRep near the top of this file. It + * clearly should not have the value NULL; it should point to the char + * tclEmptyString. If we see it having the value NULL, then somehow we + * are seeing a Tcl library that isn't completely initialized, and + * that's an indicator for the error condition described above. + * (Further explanation is welcome.) * * Third, so what do we do about it? This situation indicates the * package we just loaded wasn't properly compiled to be stub-enabled, @@ -416,9 +433,11 @@ Tcl_PkgRequireProc( void *clientDataPtr) { RequireProcArgs args; + args.name = name; args.clientDataPtr = clientDataPtr; - return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); + return Tcl_NRCallObjProc(interp, + TclNRPkgRequireProc, (void *) &args, reqc, reqv); } static int @@ -426,20 +445,28 @@ TclNRPkgRequireProc( ClientData clientData, Tcl_Interp *interp, int reqc, - Tcl_Obj *const reqv[]) { + Tcl_Obj *const reqv[]) +{ RequireProcArgs *args = clientData; - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); + + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv, + args->clientDataPtr); return TCL_OK; } static int -PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) +PkgRequireCore( + ClientData data[], + Tcl_Interp *interp, + int result) { const char *name = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj *const *reqv = data[2]; int code = CheckAllRequirements(interp, reqc, reqv); Require *reqPtr; + if (code != TCL_OK) { return code; } @@ -449,56 +476,86 @@ PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) reqPtr->name = name; reqPtr->pkgPtr = FindPackage(interp, name); if (reqPtr->pkgPtr->version == NULL) { - Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); + Tcl_NRAddCallback(interp, + SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv, + PkgRequireCoreStep1); } else { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *) reqv,NULL); } return TCL_OK; } static int -PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreStep1( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Tcl_DString command; char *script; Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name /* Name of desired package. */; - if (reqPtr->pkgPtr->version == NULL) { - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it. - */ - script = ((Interp *) interp)->packageUnknown; - if (script == NULL) { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - } else { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); - - Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - Tcl_NREvalObj(interp, - Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), - TCL_EVAL_GLOBAL - ); - Tcl_DStringFree(&command); - } - return TCL_OK; - } else { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + /* + * If we've got the package in the DB already, go on to actually loading + * it. + */ + + if (reqPtr->pkgPtr->version != NULL) { + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + return TCL_OK; } + + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ + + script = ((Interp *) interp)->packageUnknown; + if (script == NULL) { + /* + * No package unknown script. Move on to finalizing. + */ + + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + return TCL_OK; + } + + /* + * Invoke the "package unknown" script synchronously. + */ + + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + Tcl_NRAddCallback(interp, + PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL); + Tcl_NREvalObj(interp, + Tcl_NewStringObj(Tcl_DStringValue(&command), + Tcl_DStringLength(&command)), + TCL_EVAL_GLOBAL); + Tcl_DStringFree(&command); return TCL_OK; } static int -PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreStep2( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; - const char *name = reqPtr->name /* Name of desired package. */; + const char *name = reqPtr->name; /* Name of desired package. */ + if ((result != TCL_OK) && (result != TCL_ERROR)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad return code: %d", result)); @@ -511,20 +568,31 @@ PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { return result; } Tcl_ResetResult(interp); - /* pkgPtr may now be invalid, so refresh it. */ + + /* + * pkgPtr may now be invalid, so refresh it. + */ + reqPtr->pkgPtr = FindPackage(interp, name); - Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); + Tcl_NRAddCallback(interp, + SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv, + PkgRequireCoreFinal); return TCL_OK; } static int -PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreFinal( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]), satisfies; Tcl_Obj **const reqv = data[2]; char *pkgVersionI; void *clientDataPtr = reqPtr->clientDataPtr; - const char *name = reqPtr->name /* Name of desired package. */; + const char *name = reqPtr->name; /* Name of desired package. */ + if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); @@ -565,14 +633,21 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { } static int -PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreCleanup( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Tcl_Free(data[0]); return result; } - static int -SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { +SelectPackage( + ClientData data[], + Tcl_Interp *interp, + int result) +{ PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ @@ -600,10 +675,10 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } /* - * The package isn't yet present. Search the list of available - * versions and invoke the script for the best available version. We - * are actually locating the best, and the best stable version. One of - * them is then chosen based on the selection mode. + * The package isn't yet present. Search the list of available versions + * and invoke the script for the best available version. We are actually + * locating the best, and the best stable version. One of them is then + * chosen based on the selection mode. */ bestPtr = NULL; @@ -616,15 +691,19 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { /* - * The provided version number has invalid syntax. This - * should not happen. This should have been caught by the - * 'package ifneeded' registering the package. + * The provided version number has invalid syntax. This should not + * happen. This should have been caught by the 'package ifneeded' + * registering the package. */ continue; } - /* Check satisfaction of requirements before considering the current version further. */ + /* + * Check satisfaction of requirements before considering the current + * version further. + */ + if (reqc > 0) { satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { @@ -646,13 +725,16 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { * The version of the package sought is better than the * currently selected version. */ + Tcl_Free(bestVersion); bestVersion = NULL; goto newbest; } } else { newbest: - /* We have found a version which is better than our max. */ + /* + * We have found a version which is better than our max. + */ bestPtr = availPtr; CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); @@ -673,18 +755,24 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { if (res > 0) { /* - * This stable version of the package sought is better - * than the currently selected stable version. + * This stable version of the package sought is better than + * the currently selected stable version. */ + Tcl_Free(bestStableVersion); bestStableVersion = NULL; goto newstable; } } else { newstable: - /* We have found a stable version which is better than our max stable. */ + /* + * We have found a stable version which is better than our max + * stable. + */ + bestStablePtr = availPtr; - CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); + CheckVersionAndConvert(interp, bestStablePtr->version, + &bestStableVersion, NULL); } Tcl_Free(availVersion); @@ -706,9 +794,9 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } /* - * Now choose a version among the two best. For 'latest' we simply - * take (actually keep) the best. For 'stable' we take the best - * stable, if there is any, or the best if there is nothing stable. + * Now choose a version among the two best. For 'latest' we simply take + * (actually keep) the best. For 'stable' we take the best stable, if + * there is any, or the best if there is nothing stable. */ if ((iPtr->packagePrefer == PKG_PREFER_STABLE) @@ -717,13 +805,14 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } if (bestPtr == NULL) { - Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } else { /* * We found an ifneeded script for the package. Be careful while * executing it: this could cause reentrancy, so (a) protect the - * script itself from deletion and (b) don't assume that bestPtr - * will still exist when the script completes. + * script itself from deletion and (b) don't assume that bestPtr will + * still exist when the script completes. */ char *versionToProvide = bestPtr->version; @@ -734,7 +823,11 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { pkgPtr->clientData = versionToProvide; pkgFiles = TclInitPkgFiles(interp); - /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ + + /* + * Push "ifneeded" package name in "tclPkgFiles" assocdata. + */ + pkgName = Tcl_Alloc(sizeof(PkgName) + strlen(name)); pkgName->nextPtr = pkgFiles->names; strcpy(pkgName->name, name); @@ -743,21 +836,31 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { TclPkgFileSeen(interp, bestPtr->pkgIndex); } reqPtr->versionToProvide = versionToProvide; - Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); - Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); + Tcl_NRAddCallback(interp, + SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, + data[3]); + Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), + TCL_EVAL_GLOBAL); } return TCL_OK; } static int -SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { +SelectPackageFinal( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; - /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ + /* + * Pop the "ifneeded" package name from "tclPkgFiles" assocdata + */ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); PkgName *pkgName = pkgFiles->names; pkgFiles->names = pkgName->nextPtr; @@ -822,14 +925,13 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { if (result != TCL_OK) { /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. + * Take a non-TCL_OK code from the script as an indication the package + * wasn't loaded properly, so the package system should not remember + * an improper load. * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. + * This is consistent with our returning NULL. If we're not willing to + * tell our caller we got a particular version, we shouldn't store + * that version for telling future callers either. */ if (reqPtr->pkgPtr->version != NULL) { @@ -840,7 +942,8 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { return result; } - Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL); return TCL_OK; } @@ -1006,7 +1109,9 @@ TclNRPackageObjCmd( } pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); if (pkgFiles) { - Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, TclGetString(objv[2])); + Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, + TclGetString(objv[2])); + if (entry) { Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); } @@ -1015,7 +1120,8 @@ TclNRPackageObjCmd( } case PKG_FORGET: { const char *keyString; - PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *) + Tcl_GetAssocData(interp, "tclPkgFiles", NULL); for (i = 2; i < objc; i++) { keyString = TclGetString(objv[i]); @@ -1089,7 +1195,7 @@ TclNRPackageObjCmd( res = CompareVersions(avi, argv3i, NULL); Tcl_Free(avi); - if (res == 0){ + if (res == 0) { if (objc == 4) { Tcl_Free(argv3i); Tcl_SetObjResult(interp, @@ -1257,12 +1363,16 @@ TclNRPackageObjCmd( Tcl_ListObjAppendElement(interp, objvListPtr, ov); Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); + Tcl_NRAddCallback(interp, + TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) argv3, INT2PTR(newobjc), + newObjvPtr, NULL); return TCL_OK; } else { int i, newobjc = objc-3; Tcl_Obj *const *newobjv = objv + 3; + if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } @@ -1270,17 +1380,20 @@ TclNRPackageObjCmd( Tcl_IncrRefCount(objvListPtr); Tcl_IncrRefCount(objv[2]); for (i = 0; i < newobjc; i++) { - /* * Tcl_Obj structures may have come from another interpreter, * so duplicate them. */ - Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); + Tcl_ListObjAppendElement(interp, objvListPtr, + Tcl_DuplicateObj(newobjv[i])); } Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); + Tcl_NRAddCallback(interp, + TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) argv2, INT2PTR(newobjc), + newObjvPtr, NULL); return TCL_OK; } break; @@ -1423,9 +1536,13 @@ TclNRPackageObjCmd( } static int -TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { - TclDecrRefCount((Tcl_Obj *)data[0]); - TclDecrRefCount((Tcl_Obj *)data[1]); +TclNRPackageObjCmdCleanup( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + TclDecrRefCount((Tcl_Obj *) data[0]); + TclDecrRefCount((Tcl_Obj *) data[1]); return result; } diff --git a/generic/tclResult.c b/generic/tclResult.c index a59a704..c75a1f1 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -210,32 +210,6 @@ Tcl_DiscardInterpState( /* *---------------------------------------------------------------------- * - * Tcl_GetStringResult -- - * - * Returns an interpreter's result value as a string. - * - * Results: - * The interpreter's result as a string. - * - * Side effects: - * If the string result is empty, the object result is moved to the - * string result, then the object result is reset. - * - *---------------------------------------------------------------------- - */ - -const char * -Tcl_GetStringResult( - register Tcl_Interp *interp)/* Interpreter whose result to return. */ -{ - Interp *iPtr = (Interp *) interp; - - return TclGetString(iPtr->objResultPtr); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SetObjResult -- * * Arrange for objPtr to be an interpreter's result value. diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 9fc8a2b..d1fee63 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3759,7 +3759,8 @@ TclStringReverse( * * TclStringReplace -- * - * Implements the inner engine of the [string replace] command. + * Implements the inner engine of the [string replace] and + * [string insert] commands. * * The result is a concatenation of a prefix from objPtr, characters * 0 through first-1, the insertPtr string value, and a suffix from @@ -3802,7 +3803,7 @@ TclStringReplace( /* * The caller very likely had to call Tcl_GetCharLength() or similar - * to be able to process index values. This means it is like that + * to be able to process index values. This means it is likely that * objPtr is either a proper "bytearray" or a "string" or else it has * a known and short string rep. */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 26ba9e5..1b3214d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -867,7 +867,7 @@ const TclStubs tclStubs = { Tcl_GetServiceMode, /* 171 */ Tcl_GetSlave, /* 172 */ Tcl_GetStdChannel, /* 173 */ - Tcl_GetStringResult, /* 174 */ + 0, /* 174 */ 0, /* 175 */ Tcl_GetVar2, /* 176 */ 0, /* 177 */ @@ -1337,6 +1337,7 @@ const TclStubs tclStubs = { Tcl_IncrRefCount, /* 641 */ Tcl_DecrRefCount, /* 642 */ Tcl_IsShared, /* 643 */ + Tcl_LinkArray, /* 644 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 402ac5d..844eadb 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -308,6 +308,8 @@ static int TestinterpdeleteCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestlinkCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestlinkarrayCmd(void *dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static int TestlocaleCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -665,6 +667,7 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, NULL, NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); @@ -969,8 +972,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); @@ -3284,6 +3289,127 @@ TestlinkCmd( /* *---------------------------------------------------------------------- * + * TestlinkarrayCmd -- + * + * This function is invoked to process the "testlinkarray" Tcl command. + * It is used to test the 'Tcl_LinkArray' function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes variable links. + * + *---------------------------------------------------------------------- + */ + +static int +TestlinkarrayCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *LinkOption[] = { + "update", "remove", "create", NULL + }; + enum LinkOption { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; + static const char *LinkType[] = { + "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", + "wide", "uwide", "float", "double", "string", "char*", "binary", NULL + }; + /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */ + static int LinkTypes[] = { + TCL_LINK_CHAR, TCL_LINK_UCHAR, + TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT, + TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT, + TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, + TCL_LINK_BINARY + }; + 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! */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option args"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0, + &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LinkOption) optionIndex) { + case LINK_UPDATE: + for (i=2; i<objc; i++) { + Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i])); + } + return TCL_OK; + case LINK_REMOVE: + for (i=2; i<objc; i++) { + Tcl_UnlinkVar(interp, Tcl_GetString(objv[i])); + } + return TCL_OK; + case LINK_CREATE: + if (objc < 4) { + goto wrongArgs; + } + readonly = 0; + i = 2; + + /* + * test on switch -r... + */ + + arg = Tcl_GetStringFromObj(objv[i], &length); + if (length < 2) { + goto wrongArgs; + } + if (arg[0] == '-') { + if (arg[1] != 'r') { + goto wrongArgs; + } + readonly = TCL_LINK_READ_ONLY; + i++; + } + if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0, + &typeIndex) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1)); + return TCL_ERROR; + } + name = Tcl_GetString(objv[i++]); + + /* + * If no address is given request one in the underlying function + */ + + if (i < objc) { + if (Tcl_GetLongFromObj(interp, objv[i], &addr) == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong address value", -1)); + return TCL_ERROR; + } + } else { + addr = 0; + } + return Tcl_LinkArray(interp, name, (void *) addr, + LinkTypes[typeIndex] | readonly, size); + } + return TCL_OK; + + wrongArgs: + Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?"); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TestlocaleCmd -- * * This procedure implements the "testlocale" command. It is used diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 0833722..c89318f 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 3f23fd6..26eef26 100644 --- a/generic/tclTomMath.h +++ b/generic/tclTomMath.h @@ -7,8 +7,7 @@ * Michael Fromberger but has been written from scratch with * additional optimizations in place. * - * The library is free for all purposes without any express - * guarantee it works. + * SPDX-License-Identifier: Unlicense */ #ifndef BN_H_ #define BN_H_ @@ -128,6 +127,7 @@ typedef unsigned long long mp_word; #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 */ @@ -346,15 +346,20 @@ int mp_cnt_lsb(const mp_int *a); /* I Love Earth! */ -/* makes a pseudo-random int of a given size */ +/* makes a pseudo-random mp_int of a given size */ /* int mp_rand(mp_int *a, int digits); */ +/* makes a pseudo-random small int of a given size */ +/* +int mp_rand_digit(mp_digit *r); +*/ #ifdef MP_PRNG_ENABLE_LTM_RNG -/* as last resort we will fall back to libtomcrypt's rng_get_bytes() - * in case you don't use libtomcrypt or use it w/o rng_get_bytes() - * you have to implement it somewhere else, as it's required */ +/* A last resort to provide random data on systems without any of the other + * implemented ways to gather entropy. + * It is compatible with `rng_get_bytes()` from libtomcrypt so you could + * provide that one and then set `ltm_rng = rng_get_bytes;` */ extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void)); extern void (*ltm_rng_callback)(void); #endif @@ -691,10 +696,17 @@ int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *result); int mp_prime_rabin_miller_trials(int size); */ -/* performs t rounds of Miller-Rabin on "a" using the first - * t prime bases. Also performs an initial sieve of trial +/* performs t random rounds of Miller-Rabin on "a" additional to + * bases 2 and 3. Also performs an initial sieve of trial * division. Determines if "a" is prime with probability * of error no more than (1/4)**t. + * Both a strong Lucas-Selfridge to complete the BPSW test + * and a separate Frobenius test are available at compile time. + * With t<0 a deterministic test is run for primes up to + * 318665857834031151167461. With t<13 (abs(t)-13) additional + * tests with sequential small primes are run starting at 43. + * Is Fips 186.4 compliant if called with t as computed by + * mp_prime_rabin_miller_trials(); * * Sets result to 1 if probably prime, 0 otherwise */ diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index e61fb3a..d644331 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -30,19 +30,18 @@ /* Define custom memory allocation for libtommath */ + /* MODULE_SCOPE void* TclBNAlloc( size_t ); */ #define TclBNAlloc(s) ((void*)Tcl_Alloc((size_t)(s))) /* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */ #define TclBNRealloc(x,s) ((void*)Tcl_Realloc((char*)(x),(size_t)(s))) /* MODULE_SCOPE void TclBNFree( void* ); */ #define TclBNFree(x) (Tcl_Free((char*)(x))) -/* MODULE_SCOPE void* TclBNCalloc( size_t, size_t ); */ -/* unused - no macro */ -#define XMALLOC(x) TclBNAlloc(x) -#define XFREE(x) TclBNFree(x) -#define XREALLOC(x,n) TclBNRealloc(x,n) -#define XCALLOC(n,x) TclBNCalloc(n,x) +#define XMALLOC(size) TclBNAlloc(size) +#define XFREE(mem, size) TclBNFree(mem) +#define XREALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize) + /* Rename the global symbols in libtommath to avoid linkage conflicts */ diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 72c856d..32b1e15 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -111,7 +111,7 @@ TclInitBignumFromWideInt( mp_int *a, /* Bignum to initialize */ Tcl_WideInt v) /* Initial value */ { - if (mp_init_size(a, (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) != MP_OKAY) { + if (mp_init(a) != MP_OKAY) { Tcl_Panic("initialization failure in TclInitBignumFromWideInt"); } if (v < (Tcl_WideInt)0) { @@ -143,7 +143,7 @@ TclInitBignumFromWideUInt( mp_int *a, /* Bignum to initialize */ Tcl_WideUInt v) /* Initial value */ { - if (mp_init_size(a, (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) != MP_OKAY) { + if (mp_init(a) != MP_OKAY) { Tcl_Panic("initialization failure in TclInitBignumFromWideUInt"); } mp_set_long_long(a, v); diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c index 324f2a3..715904c 100644 --- a/generic/tclTomMathStubLib.c +++ b/generic/tclTomMathStubLib.c @@ -55,9 +55,9 @@ TclTomMathInitializeStubs( } if (stubsPtr == NULL) { errMsg = "missing stub table pointer"; - } else if(stubsPtr->tclBN_epoch() != epoch) { + } else if (stubsPtr->tclBN_epoch() != epoch) { errMsg = "epoch number mismatch"; - } else if(stubsPtr->tclBN_revision() != revision) { + } else if (stubsPtr->tclBN_revision() != revision) { errMsg = "requires a later revision"; } else { tclTomMathStubsPtr = stubsPtr; diff --git a/generic/tclUtf.c b/generic/tclUtf.c index b893afb..5177fd0 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1148,7 +1148,7 @@ Tcl_UtfToUpper( */ if ((len < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(upChar, dst); @@ -1210,7 +1210,7 @@ Tcl_UtfToLower( */ if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(lowChar, dst); @@ -1269,7 +1269,7 @@ Tcl_UtfToTitle( titleChar = Tcl_UniCharToTitle(titleChar); if ((len < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(titleChar, dst); @@ -1292,7 +1292,7 @@ Tcl_UtfToTitle( } if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { - memcpy(dst, src, len); + memmove(dst, src, len); dst += len; } else { dst += Tcl_UniCharToUtf(lowChar, dst); diff --git a/generic/tclVar.c b/generic/tclVar.c index c457be7..86b386c 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -722,7 +722,7 @@ TclObjLookupVarEx( Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); if (part1Ptr == cachedNamePtr) { - cachedNamePtr = NULL; + LocalSetIntRep(part1Ptr, index, NULL); } else { /* * [80304238ac] Trickiness here. We will store and incr the @@ -735,6 +735,14 @@ TclObjLookupVarEx( * cachedNamePtr and leave it as string only. This is * radical and destructive, so a better idea would be welcome. */ + + /* + * Firstly set cached local var reference (avoid free before set, + * see [45b9faf103f2]) + */ + LocalSetIntRep(part1Ptr, index, cachedNamePtr); + + /* Then wipe it */ TclFreeIntRep(cachedNamePtr); /* @@ -744,7 +752,6 @@ TclObjLookupVarEx( */ LocalSetIntRep(cachedNamePtr, index, NULL); } - LocalSetIntRep(part1Ptr, index, cachedNamePtr); } else { /* * At least mark part1Ptr as already parsed. diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index e7c1f90..ca15b38 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); @@ -1280,6 +1281,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 = Tcl_Alloc(zf->nameLength + 1); @@ -1673,9 +1675,16 @@ TclZipfs_Mount( return TCL_ERROR; } if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { + Tcl_Free(zf); return TCL_ERROR; } - return ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname); + if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname) + != TCL_OK) { + Tcl_Free(zf); + return TCL_ERROR; + } + Tcl_Free(zf); + return TCL_OK; } /* @@ -1705,6 +1714,7 @@ TclZipfs_MountBuffer( int copy) { ZipFile *zf; + int result; ReadLock(); if (!ZipFS.initialized) { @@ -1762,11 +1772,14 @@ TclZipfs_MountBuffer( zf->data = data; zf->ptrToFree = NULL; } + zf->passBuf[0] = 0; /* stop valgrind cries */ if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) { return TCL_ERROR; } - return ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL, + result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL, "Memory Buffer"); + Tcl_Free(zf); + return result; } /* @@ -1834,6 +1847,7 @@ TclZipfs_Unmount( Tcl_Free(z); } ZipFSCloseArchive(interp, zf); + Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf); Tcl_Free(zf); unmounted = 1; done: @@ -1905,7 +1919,7 @@ ZipFSMountBufferObjCmd( unsigned char *data; size_t length = 0; - if (objc > 4) { + if (objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?"); return TCL_ERROR; } @@ -4819,6 +4833,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"); + } +} + /* *------------------------------------------------------------------------- * diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 30a35d5..df0372b 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -423,7 +423,7 @@ GenerateHeader( Tcl_Obj *value; int len, result = TCL_ERROR; size_t length; - Tcl_WideInt wideValue; + Tcl_WideInt wideValue = 0; const char *valueStr; Tcl_Encoding latin1enc; static const char *const types[] = { |