From 053db4a05b6eadcabac3dfb3717e90d5f710ff18 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Tue, 11 Jun 2013 08:19:56 +0000 Subject: Move the disassembler to its own file. --- generic/tclCompile.c | 785 ---------------------------------- generic/tclCompile.h | 18 +- generic/tclDisassemble.c | 1045 ++++++++++++++++++++++++++++++++++++++++++++++ generic/tclProc.c | 258 +----------- unix/Makefile.in | 11 +- win/Makefile.in | 1 + win/makefile.bc | 5 + win/makefile.vc | 7 +- 8 files changed, 1091 insertions(+), 1039 deletions(-) create mode 100644 generic/tclDisassemble.c diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c361430..f93bbad 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -576,11 +576,6 @@ static void RegisterAuxDataType(const AuxDataType *typePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void StartExpanding(CompileEnv *envPtr); -static int FormatInstruction(ByteCode *codePtr, - const unsigned char *pc, Tcl_Obj *bufferObj); -static void PrintSourceToObj(Tcl_Obj *appendObj, - const char *stringPtr, int maxChars); -static void UpdateStringOfInstName(Tcl_Obj *objPtr); /* * TIP #280: Helper for building the per-word line information of all compiled @@ -619,19 +614,6 @@ static const Tcl_ObjType substCodeType = { }; /* - * The structure below defines an instruction name Tcl object to allow - * reporting of inner contexts in errorstack without string allocation. - */ - -static const Tcl_ObjType tclInstNameType = { - "instname", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfInstName, /* updateStringProc */ - NULL, /* setFromAnyProc */ -}; - -/* * Helper macros. */ @@ -4411,773 +4393,6 @@ EncodeCmdLocMap( return p; } -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * TclPrintByteCodeObj -- - * - * This procedure prints ("disassembles") the instructions of a bytecode - * object to stdout. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintByteCodeObj( - Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); - - fprintf(stdout, "\n%s", TclGetString(bufPtr)); - Tcl_DecrRefCount(bufPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintInstruction -- - * - * This procedure prints ("disassembles") one instruction from a bytecode - * object to stdout. - * - * Results: - * Returns the length in bytes of the current instruiction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclPrintInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc) /* Points to first byte of instruction. */ -{ - Tcl_Obj *bufferObj; - int numBytes; - - TclNewObj(bufferObj); - numBytes = FormatInstruction(codePtr, pc, bufferObj); - fprintf(stdout, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintObject -- - * - * This procedure prints up to a specified number of characters from the - * argument Tcl object's string representation to a specified file. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintObject( - FILE *outFile, /* The file to print the source to. */ - Tcl_Obj *objPtr, /* Points to the Tcl object whose string - * representation should be printed. */ - int maxChars) /* Maximum number of chars to print. */ -{ - char *bytes; - int length; - - bytes = Tcl_GetStringFromObj(objPtr, &length); - TclPrintSource(outFile, bytes, TclMin(length, maxChars)); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintSource -- - * - * This procedure prints up to a specified number of characters from the - * argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintSource( - FILE *outFile, /* The file to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - Tcl_Obj *bufferObj; - - TclNewObj(bufferObj); - PrintSourceToObj(bufferObj, stringPtr, maxChars); - fprintf(outFile, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * TclDisassembleByteCodeObj -- - * - * Given an object which is of bytecode type, return a disassembled - * version of the bytecode (in a new refcount 0 object). No guarantees - * are made about the details of the contents of the result. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclDisassembleByteCodeObj( - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - unsigned char *codeStart, *codeLimit, *pc; - unsigned char *codeDeltaNext, *codeLengthNext; - unsigned char *srcDeltaNext, *srcLengthNext; - int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; - Interp *iPtr = (Interp *) *codePtr->interpHandle; - Tcl_Obj *bufferObj; - char ptrBuf1[20], ptrBuf2[20]; - - TclNewObj(bufferObj); - if (codePtr->refCount <= 0) { - return bufferObj; /* Already freed. */ - } - - codeStart = codePtr->codeStart; - codeLimit = codeStart + codePtr->numCodeBytes; - numCmds = codePtr->numCommands; - - /* - * Print header lines describing the ByteCode. - */ - - sprintf(ptrBuf1, "%p", codePtr); - sprintf(ptrBuf2, "%p", iPtr); - Tcl_AppendPrintfToObj(bufferObj, - "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", - ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, - iPtr->compileEpoch); - Tcl_AppendToObj(bufferObj, " Source ", -1); - PrintSourceToObj(bufferObj, codePtr->source, - TclMin(codePtr->numSrcBytes, 55)); - Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, - codePtr->numLitObjects, codePtr->numAuxDataItems, - codePtr->maxStackDepth, -#ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - codePtr->structureSize/(float)codePtr->numSrcBytes : -#endif - 0.0); - -#ifdef TCL_COMPILE_STATS - Tcl_AppendPrintfToObj(bufferObj, - " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), - codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), - codePtr->numCmdLocBytes); -#endif /* TCL_COMPILE_STATS */ - - /* - * If the ByteCode is the compiled body of a Tcl procedure, print - * information about that procedure. Note that we don't know the - * procedure's name since ByteCode's can be shared among procedures. - */ - - if (codePtr->procPtr != NULL) { - Proc *procPtr = codePtr->procPtr; - int numCompiledLocals = procPtr->numCompiledLocals; - - sprintf(ptrBuf1, "%p", procPtr); - Tcl_AppendPrintfToObj(bufferObj, - " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", - ptrBuf1, procPtr->refCount, procPtr->numArgs, - numCompiledLocals); - if (numCompiledLocals > 0) { - CompiledLocal *localPtr = procPtr->firstLocalPtr; - - for (i = 0; i < numCompiledLocals; i++) { - Tcl_AppendPrintfToObj(bufferObj, - " slot %d%s%s%s%s%s%s", i, - (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", - (localPtr->flags & VAR_ARRAY) ? ", array" : "", - (localPtr->flags & VAR_LINK) ? ", link" : "", - (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", - (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", - (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); - if (TclIsVarTemporary(localPtr)) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } else { - Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", - localPtr->name); - } - localPtr = localPtr->nextPtr; - } - } - } - - /* - * Print the ExceptionRange array. - */ - - if (codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", - codePtr->numExceptRanges, codePtr->maxExceptDepth); - for (i = 0; i < codePtr->numExceptRanges; i++) { - ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; - - Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %d-%d, ", - i, rangePtr->nestingLevel, - (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), - rangePtr->codeOffset, - (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); - break; - case CATCH_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", - rangePtr->catchOffset); - break; - default: - Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", - rangePtr->type); - } - } - } - - /* - * If there were no commands (e.g., an expression or an empty string was - * compiled), just print all instructions and return. - */ - - if (numCmds == 0) { - pc = codeStart; - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - return bufferObj; - } - - /* - * Print table showing the code offset, source offset, and source length - * for each command. These are encoded as a sequence of bytes. - */ - - Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); - codeDeltaNext = codePtr->codeDeltaStart; - codeLengthNext = codePtr->codeLengthStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { - codeLengthNext++; - codeLen = TclGetInt4AtPtr(codeLengthNext); - codeLengthNext += 4; - } else { - codeLen = TclGetInt1AtPtr(codeLengthNext); - codeLengthNext++; - } - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", - ((i % 2)? " " : "\n "), - (i+1), codeOffset, (codeOffset + codeLen - 1), - srcOffset, (srcOffset + srcLen - 1)); - } - if (numCmds > 0) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } - - /* - * Print each instruction. If the instruction corresponds to the start of - * a command, print the command's source. Note that we don't need the code - * length here. - */ - - codeDeltaNext = codePtr->codeDeltaStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - pc = codeStart; - for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - /* - * Print instructions before command i. - */ - - while ((pc-codeStart) < codeOffset) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - - Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); - PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), - TclMin(srcLen, 55)); - Tcl_AppendToObj(bufferObj, "\n", -1); - } - if (pc < codeLimit) { - /* - * Print instructions after the last command. - */ - - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - } - return bufferObj; -} - -/* - *---------------------------------------------------------------------- - * - * FormatInstruction -- - * - * Appends a representation of a bytecode instruction to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static int -FormatInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc, /* Points to first byte of instruction. */ - Tcl_Obj *bufferObj) /* Object to append instruction info to. */ -{ - Proc *procPtr = codePtr->procPtr; - unsigned char opCode = *pc; - register const InstructionDesc *instDesc = &tclInstructionTable[opCode]; - unsigned char *codeStart = codePtr->codeStart; - unsigned pcOffset = pc - codeStart; - int opnd = 0, i, j, numBytes = 1; - int localCt = procPtr ? procPtr->numCompiledLocals : 0; - CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; - char suffixBuffer[128]; /* Additional info to print after main opcode - * and immediates. */ - char *suffixSrc = NULL; - Tcl_Obj *suffixObj = NULL; - AuxData *auxPtr = NULL; - - suffixBuffer[0] = '\0'; - Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); - for (i = 0; i < instDesc->numOperands; i++) { - switch (instDesc->opTypes[i]) { - case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 - || opCode == INST_JUMP_FALSE1) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - break; - case OPERAND_INT4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 - || opCode == INST_JUMP_FALSE4) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } else if (opCode == INST_START_CMD) { - sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - break; - case OPERAND_UINT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_PUSH1) { - suffixObj = codePtr->objArrayPtr[opnd]; - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - break; - case OPERAND_AUX4: - case OPERAND_UINT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_PUSH4) { - suffixObj = codePtr->objArrayPtr[opnd]; - } else if (opCode == INST_START_CMD && opnd != 1) { - sprintf(suffixBuffer+strlen(suffixBuffer), - ", %u cmds start here", opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - if (instDesc->opTypes[i] == OPERAND_AUX4) { - auxPtr = &codePtr->auxDataArrayPtr[opnd]; - } - break; - case OPERAND_IDX4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opnd >= -1) { - Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); - } else if (opnd == -2) { - Tcl_AppendPrintfToObj(bufferObj, "end "); - } else { - Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); - } - break; - case OPERAND_LVT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); - numBytes++; - goto printLVTindex; - case OPERAND_LVT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); - numBytes += 4; - printLVTindex: - if (localPtr != NULL) { - if (opnd >= localCt) { - Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", - (unsigned) opnd, localCt); - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); - } else { - sprintf(suffixBuffer, "var "); - suffixSrc = localPtr->name; - } - } - Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); - break; - case OPERAND_NONE: - default: - break; - } - } - if (suffixObj) { - const char *bytes; - int length; - - Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); - PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); - } else if (suffixBuffer[0]) { - Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); - if (suffixSrc) { - PrintSourceToObj(bufferObj, suffixSrc, 40); - } - } - Tcl_AppendToObj(bufferObj, "\n", -1); - if (auxPtr && auxPtr->type->printProc) { - Tcl_AppendToObj(bufferObj, "\t\t[", -1); - auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, - pcOffset); - Tcl_AppendToObj(bufferObj, "]\n", -1); - } - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetInnerContext -- - * - * If possible, returns a list capturing the inner context. Otherwise - * return NULL. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclGetInnerContext( - Tcl_Interp *interp, - const unsigned char *pc, - Tcl_Obj **tosPtr) -{ - int objc = 0, off = 0; - Tcl_Obj *result; - Interp *iPtr = (Interp *) interp; - - switch (*pc) { - case INST_STR_LEN: - case INST_LNOT: - case INST_BITNOT: - case INST_UMINUS: - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: - case INST_EXPAND_STKTOP: - case INST_EXPR_STK: - objc = 1; - break; - - case INST_LIST_IN: - case INST_LIST_NOT_IN: /* Basic list containment operators. */ - case INST_STR_EQ: - case INST_STR_NEQ: /* String (in)equality check */ - case INST_STR_CMP: /* String compare. */ - case INST_STR_INDEX: - case INST_STR_MATCH: - case INST_REGEXP: - case INST_EQ: - case INST_NEQ: - case INST_LT: - case INST_GT: - case INST_LE: - case INST_GE: - case INST_MOD: - case INST_LSHIFT: - case INST_RSHIFT: - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - case INST_EXPON: - case INST_ADD: - case INST_SUB: - case INST_DIV: - case INST_MULT: - objc = 2; - break; - - case INST_RETURN_STK: - /* early pop. TODO: dig out opt dict too :/ */ - objc = 1; - break; - - case INST_SYNTAX: - case INST_RETURN_IMM: - objc = 2; - break; - - case INST_INVOKE_STK4: - objc = TclGetUInt4AtPtr(pc+1); - break; - - case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); - break; - } - - result = iPtr->innerContext; - if (Tcl_IsShared(result)) { - Tcl_DecrRefCount(result); - iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); - Tcl_IncrRefCount(result); - } else { - int len; - - /* - * Reset while keeping the list intrep as much as possible. - */ - - Tcl_ListObjLength(interp, result, &len); - Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); - } - Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); - - for (; objc>0 ; objc--) { - Tcl_Obj *objPtr; - - objPtr = tosPtr[1 - objc + off]; - if (!objPtr) { - Tcl_Panic("InnerContext: bad tos -- appending null object"); - } - if ((objPtr->refCount<=0) -#ifdef TCL_MEM_DEBUG - || (objPtr->refCount==0x61616161) -#endif - ) { - Tcl_Panic("InnerContext: bad tos -- appending freed object %p", - objPtr); - } - Tcl_ListObjAppendElement(NULL, result, objPtr); - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclNewInstNameObj -- - * - * Creates a new InstName Tcl_Obj based on the given instruction - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclNewInstNameObj( - unsigned char inst) -{ - Tcl_Obj *objPtr = Tcl_NewObj(); - - objPtr->typePtr = &tclInstNameType; - objPtr->internalRep.longValue = (long) inst; - objPtr->bytes = NULL; - - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfInstName -- - * - * Update the string representation for an instruction name object. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfInstName( - Tcl_Obj *objPtr) -{ - int inst = objPtr->internalRep.longValue; - char *s, buf[20]; - int len; - - if ((inst < 0) || (inst > LAST_INST_OPCODE)) { - sprintf(buf, "inst_%d", inst); - s = buf; - } else { - s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; - } - len = strlen(s); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, s, len + 1); - objPtr->length = len; -} - -/* - *---------------------------------------------------------------------- - * - * PrintSourceToObj -- - * - * Appends a quoted representation of a string to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static void -PrintSourceToObj( - Tcl_Obj *appendObj, /* The object to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - register const char *p; - register int i = 0; - - if (stringPtr == NULL) { - Tcl_AppendToObj(appendObj, "\"\"", -1); - return; - } - - Tcl_AppendToObj(appendObj, "\"", -1); - p = stringPtr; - for (; (*p != '\0') && (i < maxChars); p++, i++) { - switch (*p) { - case '"': - Tcl_AppendToObj(appendObj, "\\\"", -1); - continue; - case '\f': - Tcl_AppendToObj(appendObj, "\\f", -1); - continue; - case '\n': - Tcl_AppendToObj(appendObj, "\\n", -1); - continue; - case '\r': - Tcl_AppendToObj(appendObj, "\\r", -1); - continue; - case '\t': - Tcl_AppendToObj(appendObj, "\\t", -1); - continue; - case '\v': - Tcl_AppendToObj(appendObj, "\\v", -1); - continue; - default: - Tcl_AppendPrintfToObj(appendObj, "%c", *p); - continue; - } - } - Tcl_AppendToObj(appendObj, "\"", -1); -} - #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..f28403d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -48,6 +48,13 @@ MODULE_SCOPE int tclTraceCompile; MODULE_SCOPE int tclTraceExec; #endif + +/* + * The type of lambda expressions. Note that every lambda will *always* have a + * string representation. + */ + +MODULE_SCOPE const Tcl_ObjType tclLambdaType; /* *------------------------------------------------------------------------ @@ -1099,12 +1106,15 @@ MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, - const char *script, - const char *command, int length, - const unsigned char *pc, Tcl_Obj **tosPtr); + const char *script, const char *command, + int length, const unsigned char *pc, + Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, - const unsigned char *pc, Tcl_Obj **tosPtr); + const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); +MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, + register Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int isLambda); /* diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c new file mode 100644 index 0000000..bc84763 --- /dev/null +++ b/generic/tclDisassemble.c @@ -0,0 +1,1045 @@ +/* + * tclDisassemble.c -- + * + * This file contains procedures that disassemble bytecode into either + * human-readable or Tcl-processable forms. + * + * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2013 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 "tclCompile.h" +#include "tclOOInt.h" +#include + +/* + * Prototypes for procedures defined later in this file: + */ + +static int FormatInstruction(ByteCode *codePtr, + const unsigned char *pc, Tcl_Obj *bufferObj); +static void PrintSourceToObj(Tcl_Obj *appendObj, + const char *stringPtr, int maxChars); +static void UpdateStringOfInstName(Tcl_Obj *objPtr); + +/* + * The structure below defines an instruction name Tcl object to allow + * reporting of inner contexts in errorstack without string allocation. + */ + +static const Tcl_ObjType tclInstNameType = { + "instname", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInstName, /* updateStringProc */ + NULL, /* setFromAnyProc */ +}; + +#ifdef TCL_COMPILE_DEBUG +/* + *---------------------------------------------------------------------- + * + * TclPrintByteCodeObj -- + * + * This procedure prints ("disassembles") the instructions of a bytecode + * object to stdout. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintByteCodeObj( + Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); + + fprintf(stdout, "\n%s", TclGetString(bufPtr)); + Tcl_DecrRefCount(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a bytecode + * object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclPrintInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + const unsigned char *pc) /* Points to first byte of instruction. */ +{ + Tcl_Obj *bufferObj; + int numBytes; + + TclNewObj(bufferObj); + numBytes = FormatInstruction(codePtr, pc, bufferObj); + fprintf(stdout, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintObject -- + * + * This procedure prints up to a specified number of characters from the + * argument Tcl object's string representation to a specified file. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintObject( + FILE *outFile, /* The file to print the source to. */ + Tcl_Obj *objPtr, /* Points to the Tcl object whose string + * representation should be printed. */ + int maxChars) /* Maximum number of chars to print. */ +{ + char *bytes; + int length; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from the + * argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintSource( + FILE *outFile, /* The file to print the source to. */ + const char *stringPtr, /* The string to print. */ + int maxChars) /* Maximum number of chars to print. */ +{ + Tcl_Obj *bufferObj; + + TclNewObj(bufferObj); + PrintSourceToObj(bufferObj, stringPtr, maxChars); + fprintf(outFile, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclDisassembleByteCodeObj -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object). No guarantees + * are made about the details of the contents of the result. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDisassembleByteCodeObj( + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + unsigned char *codeStart, *codeLimit, *pc; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; + Interp *iPtr = (Interp *) *codePtr->interpHandle; + Tcl_Obj *bufferObj; + char ptrBuf1[20], ptrBuf2[20]; + + TclNewObj(bufferObj); + if (codePtr->refCount <= 0) { + return bufferObj; /* Already freed. */ + } + + codeStart = codePtr->codeStart; + codeLimit = codeStart + codePtr->numCodeBytes; + numCmds = codePtr->numCommands; + + /* + * Print header lines describing the ByteCode. + */ + + sprintf(ptrBuf1, "%p", codePtr); + sprintf(ptrBuf2, "%p", iPtr); + Tcl_AppendPrintfToObj(bufferObj, + "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", + ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, + iPtr->compileEpoch); + Tcl_AppendToObj(bufferObj, " Source ", -1); + PrintSourceToObj(bufferObj, codePtr->source, + TclMin(codePtr->numSrcBytes, 55)); + Tcl_AppendPrintfToObj(bufferObj, + "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, + codePtr->numLitObjects, codePtr->numAuxDataItems, + codePtr->maxStackDepth, +#ifdef TCL_COMPILE_STATS + codePtr->numSrcBytes? + codePtr->structureSize/(float)codePtr->numSrcBytes : +#endif + 0.0); + +#ifdef TCL_COMPILE_STATS + Tcl_AppendPrintfToObj(bufferObj, + " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + (unsigned long) codePtr->structureSize, + (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), + codePtr->numCodeBytes, + (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), + (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); +#endif /* TCL_COMPILE_STATS */ + + /* + * If the ByteCode is the compiled body of a Tcl procedure, print + * information about that procedure. Note that we don't know the + * procedure's name since ByteCode's can be shared among procedures. + */ + + if (codePtr->procPtr != NULL) { + Proc *procPtr = codePtr->procPtr; + int numCompiledLocals = procPtr->numCompiledLocals; + + sprintf(ptrBuf1, "%p", procPtr); + Tcl_AppendPrintfToObj(bufferObj, + " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", + ptrBuf1, procPtr->refCount, procPtr->numArgs, + numCompiledLocals); + if (numCompiledLocals > 0) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + + for (i = 0; i < numCompiledLocals; i++) { + Tcl_AppendPrintfToObj(bufferObj, + " slot %d%s%s%s%s%s%s", i, + (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", + (localPtr->flags & VAR_ARRAY) ? ", array" : "", + (localPtr->flags & VAR_LINK) ? ", link" : "", + (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", + (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", + (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); + if (TclIsVarTemporary(localPtr)) { + Tcl_AppendToObj(bufferObj, "\n", -1); + } else { + Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", + localPtr->name); + } + localPtr = localPtr->nextPtr; + } + } + } + + /* + * Print the ExceptionRange array. + */ + + if (codePtr->numExceptRanges > 0) { + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", + codePtr->numExceptRanges, codePtr->maxExceptDepth); + for (i = 0; i < codePtr->numExceptRanges; i++) { + ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; + + Tcl_AppendPrintfToObj(bufferObj, + " %d: level %d, %s, pc %d-%d, ", + i, rangePtr->nestingLevel, + (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); + break; + case CATCH_EXCEPTION_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", + rangePtr->catchOffset); + break; + default: + Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", + rangePtr->type); + } + } + } + + /* + * If there were no commands (e.g., an expression or an empty string was + * compiled), just print all instructions and return. + */ + + if (numCmds == 0) { + pc = codeStart; + while (pc < codeLimit) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + return bufferObj; + } + + /* + * Print table showing the code offset, source offset, and source length + * for each command. These are encoded as a sequence of bytes. + */ + + Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", + ((i % 2)? " " : "\n "), + (i+1), codeOffset, (codeOffset + codeLen - 1), + srcOffset, (srcOffset + srcLen - 1)); + } + if (numCmds > 0) { + Tcl_AppendToObj(bufferObj, "\n", -1); + } + + /* + * Print each instruction. If the instruction corresponds to the start of + * a command, print the command's source. Note that we don't need the code + * length here. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + pc = codeStart; + for (i = 0; i < numCmds; i++) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + /* + * Print instructions before command i. + */ + + while ((pc-codeStart) < codeOffset) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + + Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); + PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), + TclMin(srcLen, 55)); + Tcl_AppendToObj(bufferObj, "\n", -1); + } + if (pc < codeLimit) { + /* + * Print instructions after the last command. + */ + + while (pc < codeLimit) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + } + return bufferObj; +} + +/* + *---------------------------------------------------------------------- + * + * FormatInstruction -- + * + * Appends a representation of a bytecode instruction to a Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +static int +FormatInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + const unsigned char *pc, /* Points to first byte of instruction. */ + Tcl_Obj *bufferObj) /* Object to append instruction info to. */ +{ + Proc *procPtr = codePtr->procPtr; + unsigned char opCode = *pc; + register const InstructionDesc *instDesc = &tclInstructionTable[opCode]; + unsigned char *codeStart = codePtr->codeStart; + unsigned pcOffset = pc - codeStart; + int opnd = 0, i, j, numBytes = 1; + int localCt = procPtr ? procPtr->numCompiledLocals : 0; + CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; + char suffixBuffer[128]; /* Additional info to print after main opcode + * and immediates. */ + char *suffixSrc = NULL; + Tcl_Obj *suffixObj = NULL; + AuxData *auxPtr = NULL; + + suffixBuffer[0] = '\0'; + Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); + for (i = 0; i < instDesc->numOperands; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 + || opCode == INST_JUMP_FALSE1) { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_INT4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 + || opCode == INST_JUMP_FALSE4) { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + } else if (opCode == INST_START_CMD) { + sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_UINT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + if (opCode == INST_PUSH1) { + suffixObj = codePtr->objArrayPtr[opnd]; + } + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_AUX4: + case OPERAND_UINT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_PUSH4) { + suffixObj = codePtr->objArrayPtr[opnd]; + } else if (opCode == INST_START_CMD && opnd != 1) { + sprintf(suffixBuffer+strlen(suffixBuffer), + ", %u cmds start here", opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + if (instDesc->opTypes[i] == OPERAND_AUX4) { + auxPtr = &codePtr->auxDataArrayPtr[opnd]; + } + break; + case OPERAND_IDX4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opnd >= -1) { + Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); + } else if (opnd == -2) { + Tcl_AppendPrintfToObj(bufferObj, "end "); + } else { + Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); + } + break; + case OPERAND_LVT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; + goto printLVTindex; + case OPERAND_LVT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); + numBytes += 4; + printLVTindex: + if (localPtr != NULL) { + if (opnd >= localCt) { + Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", + (unsigned) opnd, localCt); + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); + } else { + sprintf(suffixBuffer, "var "); + suffixSrc = localPtr->name; + } + } + Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); + break; + case OPERAND_NONE: + default: + break; + } + } + if (suffixObj) { + const char *bytes; + int length; + + Tcl_AppendToObj(bufferObj, "\t# ", -1); + bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); + PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); + } else if (suffixBuffer[0]) { + Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); + if (suffixSrc) { + PrintSourceToObj(bufferObj, suffixSrc, 40); + } + } + Tcl_AppendToObj(bufferObj, "\n", -1); + if (auxPtr && auxPtr->type->printProc) { + Tcl_AppendToObj(bufferObj, "\t\t[", -1); + auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, + pcOffset); + Tcl_AppendToObj(bufferObj, "]\n", -1); + } + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetInnerContext -- + * + * If possible, returns a list capturing the inner context. Otherwise + * return NULL. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetInnerContext( + Tcl_Interp *interp, + const unsigned char *pc, + Tcl_Obj **tosPtr) +{ + int objc = 0, off = 0; + Tcl_Obj *result; + Interp *iPtr = (Interp *) interp; + + switch (*pc) { + case INST_STR_LEN: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + case INST_EXPAND_STKTOP: + case INST_EXPR_STK: + objc = 1; + break; + + case INST_LIST_IN: + case INST_LIST_NOT_IN: /* Basic list containment operators. */ + case INST_STR_EQ: + case INST_STR_NEQ: /* String (in)equality check */ + case INST_STR_CMP: /* String compare. */ + case INST_STR_INDEX: + case INST_STR_MATCH: + case INST_REGEXP: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + objc = 2; + break; + + case INST_RETURN_STK: + /* early pop. TODO: dig out opt dict too :/ */ + objc = 1; + break; + + case INST_SYNTAX: + case INST_RETURN_IMM: + objc = 2; + break; + + case INST_INVOKE_STK4: + objc = TclGetUInt4AtPtr(pc+1); + break; + + case INST_INVOKE_STK1: + objc = TclGetUInt1AtPtr(pc+1); + break; + } + + result = iPtr->innerContext; + if (Tcl_IsShared(result)) { + Tcl_DecrRefCount(result); + iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); + Tcl_IncrRefCount(result); + } else { + int len; + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjLength(interp, result, &len); + Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); + } + Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); + + for (; objc>0 ; objc--) { + Tcl_Obj *objPtr; + + objPtr = tosPtr[1 - objc + off]; + if (!objPtr) { + Tcl_Panic("InnerContext: bad tos -- appending null object"); + } + if ((objPtr->refCount<=0) +#ifdef TCL_MEM_DEBUG + || (objPtr->refCount==0x61616161) +#endif + ) { + Tcl_Panic("InnerContext: bad tos -- appending freed object %p", + objPtr); + } + Tcl_ListObjAppendElement(NULL, result, objPtr); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewInstNameObj -- + * + * Creates a new InstName Tcl_Obj based on the given instruction + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclNewInstNameObj( + unsigned char inst) +{ + Tcl_Obj *objPtr = Tcl_NewObj(); + + objPtr->typePtr = &tclInstNameType; + objPtr->internalRep.longValue = (long) inst; + objPtr->bytes = NULL; + + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfInstName -- + * + * Update the string representation for an instruction name object. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfInstName( + Tcl_Obj *objPtr) +{ + int inst = objPtr->internalRep.longValue; + char *s, buf[20]; + int len; + + if ((inst < 0) || (inst > LAST_INST_OPCODE)) { + sprintf(buf, "inst_%d", inst); + s = buf; + } else { + s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + } + len = strlen(s); + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, s, len + 1); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * PrintSourceToObj -- + * + * Appends a quoted representation of a string to a Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +static void +PrintSourceToObj( + Tcl_Obj *appendObj, /* The object to print the source to. */ + const char *stringPtr, /* The string to print. */ + int maxChars) /* Maximum number of chars to print. */ +{ + register const char *p; + register int i = 0; + + if (stringPtr == NULL) { + Tcl_AppendToObj(appendObj, "\"\"", -1); + return; + } + + Tcl_AppendToObj(appendObj, "\"", -1); + p = stringPtr; + for (; (*p != '\0') && (i < maxChars); p++, i++) { + switch (*p) { + case '"': + Tcl_AppendToObj(appendObj, "\\\"", -1); + continue; + case '\f': + Tcl_AppendToObj(appendObj, "\\f", -1); + continue; + case '\n': + Tcl_AppendToObj(appendObj, "\\n", -1); + continue; + case '\r': + Tcl_AppendToObj(appendObj, "\\r", -1); + continue; + case '\t': + Tcl_AppendToObj(appendObj, "\\t", -1); + continue; + case '\v': + Tcl_AppendToObj(appendObj, "\\v", -1); + continue; + default: + Tcl_AppendPrintfToObj(appendObj, "%c", *p); + continue; + } + } + Tcl_AppendToObj(appendObj, "\"", -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DisassembleObjCmd -- + * + * Implementation of the "::tcl::unsupported::disassemble" command. This + * command is not documented, but will disassemble procedures, lambda + * terms and general scripts. Note that will compile terms if necessary + * in order to disassemble them. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DisassembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const types[] = { + "lambda", "method", "objmethod", "proc", "script", NULL + }; + enum Types { + DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, + DISAS_SCRIPT + }; + int idx, result; + Tcl_Obj *codeObjPtr = NULL; + Proc *procPtr = NULL; + Tcl_HashEntry *hPtr; + Object *oPtr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "type ..."); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ + return TCL_ERROR; + } + + switch ((enum Types) idx) { + case DISAS_LAMBDA: { + Command cmd; + Tcl_Obj *nsObjPtr; + Tcl_Namespace *nsPtr; + + /* + * Compile (if uncompiled) and disassemble a lambda term. + */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); + return TCL_ERROR; + } + if (objv[2]->typePtr == &tclLambdaType) { + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { + result = tclLambdaType.setFromAnyProc(interp, objv[2]); + if (result != TCL_OK) { + return result; + } + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + + memset(&cmd, 0, sizeof(Command)); + nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + cmd.nsPtr = (Namespace *) nsPtr; + procPtr->cmdPtr = &cmd; + result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; + } + case DISAS_PROC: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procName"); + return TCL_ERROR; + } + + procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = TclPushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; + case DISAS_SCRIPT: + /* + * Compile and disassemble a script. + */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "script"); + return TCL_ERROR; + } + if ((objv[2]->typePtr != &tclByteCodeType) + && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + return TCL_ERROR; + } + codeObjPtr = objv[2]; + break; + + case DISAS_CLASS_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); + return TCL_ERROR; + } + + /* + * Look up the body of a class method. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, + (char *) objv[3]); + goto methodBody; + case DISAS_OBJECT_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); + return TCL_ERROR; + } + + /* + * Look up the body of an instance method. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->methodsPtr == NULL) { + goto unknownMethod; + } + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); + + /* + * Compile (if necessary) and disassemble a method body. + */ + + methodBody: + if (hPtr == NULL) { + unknownMethod: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[3]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[3]), NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); + return TCL_ERROR; + } + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of method", + TclGetString(objv[3])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + default: + CLANG_ASSERT(0); + } + + /* + * Do the actual disassembly. + */ + + if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not disassemble prebuilt bytecode", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "BYTECODE", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ diff --git a/generic/tclProc.c b/generic/tclProc.c index 18985a1..23d8e70 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -15,7 +15,6 @@ #include "tclInt.h" #include "tclCompile.h" -#include "tclOOInt.h" /* * Variables that are part of the [apply] command implementation and which @@ -41,9 +40,6 @@ static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, Namespace *nsPtr); static void InitLocalCache(Proc *procPtr); -static int PushProcCallFrame(ClientData clientData, - register Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int isLambda); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); @@ -95,7 +91,7 @@ static const Tcl_ObjType levelReferenceType = { * will execute within. */ -static const Tcl_ObjType lambdaType = { +const Tcl_ObjType tclLambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ @@ -221,7 +217,7 @@ Tcl_ProcObjCmd( * * This code is nearly identical to the #280 code in SetLambdaFromAny, see * this file. The differences are the different index of the body in the - * line array of the context, and the lamdba code requires some special + * line array of the context, and the lambda code requires some special * processing. Find a way to factor the common elements into a single * function. */ @@ -1571,7 +1567,7 @@ InitArgsAndLocals( /* *---------------------------------------------------------------------- * - * PushProcCallFrame -- + * TclPushProcCallFrame -- * * Compiles a proc body if necessary, then pushes a CallFrame suitable * for executing it. @@ -1586,8 +1582,8 @@ InitArgsAndLocals( *---------------------------------------------------------------------- */ -static int -PushProcCallFrame( +int +TclPushProcCallFrame( ClientData clientData, /* Record describing procedure to be * interpreted. */ register Tcl_Interp *interp,/* Interpreter in which procedure was @@ -1708,7 +1704,7 @@ TclNRInterpProc( * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { - int result = PushProcCallFrame(clientData, interp, objc, objv, + int result = TclPushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); if (result != TCL_OK) { @@ -2451,7 +2447,7 @@ DupLambdaInternalRep( procPtr->refCount++; Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &lambdaType; + copyPtr->typePtr = &tclLambdaType; } static void @@ -2488,7 +2484,7 @@ SetLambdaFromAny( /* * Convert objPtr to list type first; if it cannot be converted, or if its - * length is not 2, then it cannot be converted to lambdaType. + * length is not 2, then it cannot be converted to tclLambdaType. */ result = TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -2634,14 +2630,14 @@ SetLambdaFromAny( /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to lambdaType. + * conversion to tclLambdaType. */ TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = procPtr; objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - objPtr->typePtr = &lambdaType; + objPtr->typePtr = &tclLambdaType; return TCL_OK; } @@ -2692,12 +2688,12 @@ TclNRApplyObjCmd( } /* - * Set lambdaPtr, convert it to lambdaType in the current interp if + * Set lambdaPtr, convert it to tclLambdaType in the current interp if * necessary. */ lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &lambdaType) { + if (lambdaPtr->typePtr == &tclLambdaType) { procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } @@ -2775,7 +2771,7 @@ TclNRApplyObjCmd( } extraPtr->isRootEnsemble = isRootEnsemble; - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); + result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); if (result == TCL_OK) { TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); @@ -2835,234 +2831,6 @@ MakeLambdaError( } /* - *---------------------------------------------------------------------- - * - * Tcl_DisassembleObjCmd -- - * - * Implementation of the "::tcl::unsupported::disassemble" command. This - * command is not documented, but will disassemble procedures, lambda - * terms and general scripts. Note that will compile terms if necessary - * in order to disassemble them. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_DisassembleObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const types[] = { - "lambda", "method", "objmethod", "proc", "script", NULL - }; - enum Types { - DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, - DISAS_SCRIPT - }; - int idx, result; - Tcl_Obj *codeObjPtr = NULL; - Proc *procPtr = NULL; - Tcl_HashEntry *hPtr; - Object *oPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "type ..."); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ - return TCL_ERROR; - } - - switch ((enum Types) idx) { - case DISAS_LAMBDA: { - Command cmd; - Tcl_Obj *nsObjPtr; - Tcl_Namespace *nsPtr; - - /* - * Compile (if uncompiled) and disassemble a lambda term. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); - return TCL_ERROR; - } - if (objv[2]->typePtr == &lambdaType) { - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { - result = SetLambdaFromAny(interp, objv[2]); - if (result != TCL_OK) { - return result; - } - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - - memset(&cmd, 0, sizeof(Command)); - nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return result; - } - cmd.nsPtr = (Namespace *) nsPtr; - procPtr->cmdPtr = &cmd; - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - } - case DISAS_PROC: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procName"); - return TCL_ERROR; - } - - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - /* - * Compile (if uncompiled) and disassemble a procedure. - */ - - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - case DISAS_SCRIPT: - /* - * Compile and disassemble a script. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script"); - return TCL_ERROR; - } - if ((objv[2]->typePtr != &tclByteCodeType) - && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { - return TCL_ERROR; - } - codeObjPtr = objv[2]; - break; - - case DISAS_CLASS_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of a class method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) objv[3]); - goto methodBody; - case DISAS_OBJECT_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of an instance method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->methodsPtr == NULL) { - goto unknownMethod; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); - - /* - * Compile (if necessary) and disassemble a method body. - */ - - methodBody: - if (hPtr == NULL) { - unknownMethod: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[3]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[3]), NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "body not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); - return TCL_ERROR; - } - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of method", - TclGetString(objv[3])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; - default: - CLANG_ASSERT(0); - } - - /* - * Do the actual disassembly. - */ - - if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags - & TCL_BYTECODE_PRECOMPILED) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not disassemble prebuilt bytecode", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "BYTECODE", NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); - return TCL_OK; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/unix/Makefile.in b/unix/Makefile.in index 3e4a6f6..ab351ca 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -294,7 +294,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \ - tclCompile.o tclConfig.o tclDate.o tclDictObj.o \ + tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \ tclEncoding.o tclEnsemble.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ @@ -402,6 +402,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclConfig.c \ $(GENERIC_DIR)/tclDate.c \ $(GENERIC_DIR)/tclDictObj.c \ + $(GENERIC_DIR)/tclDisassemble.c \ $(GENERIC_DIR)/tclEncoding.c \ $(GENERIC_DIR)/tclEnsemble.c \ $(GENERIC_DIR)/tclEnv.c \ @@ -1097,6 +1098,9 @@ tclConfig.o: $(GENERIC_DIR)/tclConfig.c tclDictObj.o: $(GENERIC_DIR)/tclDictObj.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDictObj.c +tclDisassemble.o: $(GENERIC_DIR)/tclDisassemble.c $(COMPILEHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDisassemble.c + tclEncoding.o: $(GENERIC_DIR)/tclEncoding.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEncoding.c @@ -1562,10 +1566,9 @@ tclUnixThrd.o: $(UNIX_DIR)/tclUnixThrd.c tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c +TCL_LOCATIONS=-DTCL_LIBRARY="\"${TCL_LIBRARY}\"" -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh - $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ - -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ - $(UNIX_DIR)/tclUnixInit.c + $(CC) -c $(CC_SWITCHES) $(TCL_LOCATIONS) $(UNIX_DIR)/tclUnixInit.c tclUnixCompat.o: $(UNIX_DIR)/tclUnixCompat.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixCompat.c diff --git a/win/Makefile.in b/win/Makefile.in index 18993fe..dc54d59 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -232,6 +232,7 @@ GENERIC_OBJS = \ tclConfig.$(OBJEXT) \ tclDate.$(OBJEXT) \ tclDictObj.$(OBJEXT) \ + tclDisassemble.$(OBJEXT) \ tclEncoding.$(OBJEXT) \ tclEnsemble.$(OBJEXT) \ tclEnv.$(OBJEXT) \ diff --git a/win/makefile.bc b/win/makefile.bc index 0b17cea..31a927e 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -207,6 +207,7 @@ TCLOBJS = \ $(TMPDIR)\tclConfig.obj \ $(TMPDIR)\tclDate.obj \ $(TMPDIR)\tclDictObj.obj \ + $(TMPDIR)\tclDisassemble.obj \ $(TMPDIR)\tclEncoding.obj \ $(TMPDIR)\tclEnsemble.obj \ $(TMPDIR)\tclEnv.obj \ @@ -587,3 +588,7 @@ clean: -@$(RM) $(TMPDIR)\*.exe -@$(RMDIR) $(OUTDIR) -@$(RMDIR) $(TMPDIR) + +# Local Variables: +# mode: makefile +# End: diff --git a/win/makefile.vc b/win/makefile.vc index cddb253..09a1135 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -1,4 +1,4 @@ -#------------------------------------------------------------- -*- makefile -*- +#------------------------------------------------------------- # makefile.vc -- # # Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) @@ -281,6 +281,7 @@ COREOBJS = \ $(TMP_DIR)\tclConfig.obj \ $(TMP_DIR)\tclDate.obj \ $(TMP_DIR)\tclDictObj.obj \ + $(TMP_DIR)\tclDisassemble.obj \ $(TMP_DIR)\tclEncoding.obj \ $(TMP_DIR)\tclEnsemble.obj \ $(TMP_DIR)\tclEnv.obj \ @@ -1221,3 +1222,7 @@ realclean: hose hose: @echo Hosing $(OUT_DIR)\* ... @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) + +# Local Variables: +# mode: makefile +# End: -- cgit v0.12 From 7ef0316d365faf799092fbbf8a5c0a3406337889 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Tue, 11 Jun 2013 21:33:33 +0000 Subject: Code-readable disassembler: tcl::unsupported::getbytecode --- generic/tclBasic.c | 4 +- generic/tclDisassemble.c | 231 ++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 232 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b2a505a..f805a94 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -837,7 +837,9 @@ Tcl_CreateInterp(void) */ Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", - Tcl_DisassembleObjCmd, NULL, NULL); + Tcl_DisassembleObjCmd, INT2PTR(0), NULL); + Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode", + Tcl_DisassembleObjCmd, INT2PTR(1), NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index bc84763..2404b99 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -810,6 +810,229 @@ PrintSourceToObj( /* *---------------------------------------------------------------------- * + * DisassembleByteCodeAsDicts -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object) in a dictionary. + * No guarantees are made about the details of the contents of the + * result, but it is intended to be more readable than the old output + * format. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +DisassembleByteCodeAsDicts( + Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ +{ + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *description, *literals, *variables, *instructions, *inst; + Tcl_Obj *aux, *exn; + unsigned char *pc, *opnd; + int i, val; + + /* + * Get the literals from the bytecode. + */ + + literals = Tcl_NewObj(); + for (i=0 ; inumLitObjects ; i++) { + Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); + } + + /* + * Get the variables from the bytecode. + */ + + variables = Tcl_NewObj(); + if (codePtr->procPtr) { + int localCount = codePtr->procPtr->numCompiledLocals; + CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; + + for (i=0 ; inextPtr) { + Tcl_Obj *descriptor[2]; + + descriptor[0] = Tcl_NewObj(); + if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("scalar", -1)); + } + if (localPtr->flags & VAR_ARRAY) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("array", -1)); + } + if (localPtr->flags & VAR_LINK) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("link", -1)); + } + if (localPtr->flags & VAR_ARGUMENT) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("arg", -1)); + } + if (localPtr->flags & VAR_TEMPORARY) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("temp", -1)); + } + if (localPtr->flags & VAR_RESOLVED) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("resolved", -1)); + } + if (localPtr->flags & VAR_TEMPORARY) { + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewListObj(1, descriptor)); + } else { + descriptor[1] = Tcl_NewStringObj(localPtr->name, -1); + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewListObj(2, descriptor)); + } + } + } + + /* + * Get the instructions from the bytecode. + */ + + instructions = Tcl_NewObj(); + for (pc=codePtr->codeStart; pccodeStart+codePtr->numCodeBytes;){ + const InstructionDesc *instDesc = &tclInstructionTable[*pc]; + + inst = Tcl_NewIntObj(pc - codePtr->codeStart); + Tcl_ListObjAppendElement(NULL, inst, + Tcl_NewStringObj(instDesc->name, -1)); + opnd = pc + 1; + for (i=0 ; inumOperands ; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + val = TclGetInt1AtPtr(opnd); + opnd += 1; + if (*pc == INST_JUMP1 || *pc == INST_JUMP_TRUE1 + || *pc == INST_JUMP_FALSE1) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "pc %d (%d)", pc+val-codePtr->codeStart, val)); + } else { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + } + break; + case OPERAND_INT4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + if (*pc == INST_JUMP4 || *pc == INST_JUMP_TRUE4 + || *pc == INST_JUMP_FALSE4 || *pc == INST_START_CMD) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "pc %d (%d)", pc+val-codePtr->codeStart, val)); + } else { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + } + break; + case OPERAND_UINT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + break; + case OPERAND_UINT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + break; + case OPERAND_IDX4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + if (val >= -1) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + } else if (val == -2) { + Tcl_ListObjAppendElement(NULL, inst, + Tcl_NewStringObj("end", -1)); + } else { + Tcl_ListObjAppendElement(NULL, inst, + Tcl_ObjPrintf("end-%d", -2-val)); + } + break; + case OPERAND_LVT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + Tcl_ListObjAppendElement(NULL, inst, + Tcl_ObjPrintf("%%%d", val)); + break; + case OPERAND_LVT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + Tcl_ListObjAppendElement(NULL, inst, + Tcl_ObjPrintf("%%%d", val)); + break; + case OPERAND_AUX4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + break; + case OPERAND_NONE: + Tcl_Panic("opcode %d with more than zero 'no' operands", *pc); + } + } + Tcl_ListObjAppendElement(NULL, instructions, inst); + pc += instDesc->numBytes; + } + + /* + * Get the auxiliary data from the bytecode. + */ + + aux = Tcl_NewObj(); + for (i=0 ; inumAuxDataItems ; i++) { + AuxData *auxData = &codePtr->auxDataArrayPtr[i]; + Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); + + if (auxData->type->printProc) { + Tcl_AppendToObj(auxDesc, " ", -1); + auxData->type->printProc(auxData->clientData, auxDesc, codePtr,0); + } + Tcl_ListObjAppendElement(NULL, aux, auxDesc); + } + + /* + * Get the exception ranges from the bytecode. + */ + + exn = Tcl_NewObj(); + for (i=0 ; inumExceptRanges ; i++) { + ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; + + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( + "type %s level %d from %d to %d break %d continue %d", + "loop", rangePtr->nestingLevel, rangePtr->codeOffset, + rangePtr->codeOffset + rangePtr->numCodeBytes - 1, + rangePtr->breakOffset, rangePtr->continueOffset)); + break; + case CATCH_EXCEPTION_RANGE: + Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( + "type %s level %d from %d to %d catch %d", + "catch", rangePtr->nestingLevel, rangePtr->codeOffset, + rangePtr->codeOffset + rangePtr->numCodeBytes - 1, + rangePtr->catchOffset)); + break; + } + } + + /* + * Build the overall result. + */ + + description = Tcl_NewObj(); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1), + literals); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1), + variables); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1), + instructions); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux); + return description; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DisassembleObjCmd -- * * Implementation of the "::tcl::unsupported::disassemble" command. This @@ -822,7 +1045,7 @@ PrintSourceToObj( int Tcl_DisassembleObjCmd( - ClientData dummy, /* Not used. */ + ClientData clientData, /* What type of operation. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1031,7 +1254,11 @@ Tcl_DisassembleObjCmd( "BYTECODE", NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); + if (PTR2INT(clientData)) { + Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(codeObjPtr)); + } else { + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); + } return TCL_OK; } -- cgit v0.12 From bca601aef8483e135b6ba61a3619ebf10f1a437a Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Wed, 12 Jun 2013 08:55:15 +0000 Subject: Extract more of the info from the bytecode. --- generic/tclDisassemble.c | 65 ++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 60 insertions(+), 5 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 2404b99..0d2b844 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -827,8 +827,9 @@ DisassembleByteCodeAsDicts( { ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *description, *literals, *variables, *instructions, *inst; - Tcl_Obj *aux, *exn; - unsigned char *pc, *opnd; + Tcl_Obj *aux, *exn, *commands; + unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; + int codeOffset, codeLength, sourceOffset, sourceLength; int i, val; /* @@ -896,7 +897,7 @@ DisassembleByteCodeAsDicts( for (pc=codePtr->codeStart; pccodeStart+codePtr->numCodeBytes;){ const InstructionDesc *instDesc = &tclInstructionTable[*pc]; - inst = Tcl_NewIntObj(pc - codePtr->codeStart); + inst = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(instDesc->name, -1)); opnd = pc + 1; @@ -962,13 +963,15 @@ DisassembleByteCodeAsDicts( case OPERAND_AUX4: val = TclGetInt4AtPtr(opnd); opnd += 4; - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + Tcl_ListObjAppendElement(NULL, inst, + Tcl_ObjPrintf("?%d", val)); break; case OPERAND_NONE: Tcl_Panic("opcode %d with more than zero 'no' operands", *pc); } } - Tcl_ListObjAppendElement(NULL, instructions, inst); + Tcl_DictObjPut(NULL, instructions, + Tcl_NewIntObj(pc - codePtr->codeStart), inst); pc += instDesc->numBytes; } @@ -1015,6 +1018,48 @@ DisassembleByteCodeAsDicts( } /* + * Get the command information from the bytecode. + */ + + commands = Tcl_NewObj(); + codeOffPtr = codePtr->codeDeltaStart; + codeLenPtr = codePtr->codeLengthStart; + srcOffPtr = codePtr->srcDeltaStart; + srcLenPtr = codePtr->srcLengthStart; + codeOffset = sourceOffset = 0; +#define Decode(ptr) \ + ((TclGetUInt1AtPtr(ptr) == 0xFF) \ + ? ((ptr)+=5,TclGetInt4AtPtr((ptr)-4)) \ + : ((ptr)+=1,TclGetInt1AtPtr((ptr)-1))) + for (i=0 ; inumCommands ; i++) { + Tcl_Obj *cmd; + + codeOffset += Decode(codeOffPtr); + codeLength = Decode(codeLenPtr); + sourceOffset += Decode(srcOffPtr); + sourceLength = Decode(srcLenPtr); + cmd = Tcl_NewObj(); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1), + Tcl_NewIntObj(codeOffset)); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1), + Tcl_NewIntObj(codeOffset + codeLength - 1)); + /* + * Convert byte offsets to character offsets; important if multibyte + * characters are present in the source! + */ + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), + Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + sourceOffset))); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1), + Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + sourceOffset + sourceLength - 1))); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1), + Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); + Tcl_ListObjAppendElement(NULL, commands, cmd); + } +#undef Decode + + /* * Build the overall result. */ @@ -1027,6 +1072,16 @@ DisassembleByteCodeAsDicts( Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1), instructions); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1), + commands); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1), + Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1), + Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1), + Tcl_NewIntObj(codePtr->maxStackDepth)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1), + Tcl_NewIntObj(codePtr->maxExceptDepth)); return description; } -- cgit v0.12 From eb65f3a23000edd4b42f9800597b3d68d896d081 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Thu, 13 Jun 2013 21:21:22 +0000 Subject: Improved rendering of some opcode arguments and auxdata. --- generic/tclCompCmds.c | 86 +++++++++++++++++++++++++++++++++++++++++++++--- generic/tclCompCmdsSZ.c | 32 +++++++++++++++++- generic/tclCompile.h | 10 ++++++ generic/tclDisassemble.c | 36 +++++++++++++++----- 4 files changed, 150 insertions(+), 14 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fddf152..0740490 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -26,11 +26,17 @@ static void FreeDictUpdateInfo(ClientData clientData); static void PrintDictUpdateInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleDictUpdateInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static ClientData DupForeachInfo(ClientData clientData); static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleForeachInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); @@ -46,14 +52,16 @@ const AuxDataType tclForeachInfoType = { "ForeachInfo", /* name */ DupForeachInfo, /* dupProc */ FreeForeachInfo, /* freeProc */ - PrintForeachInfo /* printProc */ + PrintForeachInfo, /* printProc */ + DisassembleForeachInfo /* disassembleProc */ }; const AuxDataType tclDictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ FreeDictUpdateInfo, /* freeProc */ - PrintDictUpdateInfo /* printProc */ + PrintDictUpdateInfo, /* printProc */ + DisassembleDictUpdateInfo /* disassembleProc */ }; /* @@ -2065,11 +2073,13 @@ TclCompileDictWithCmd( * DupDictUpdateInfo: a copy of the auxiliary data * FreeDictUpdateInfo: none * PrintDictUpdateInfo: none + * DisassembleDictUpdateInfo: none * * Side effects: * DupDictUpdateInfo: allocates memory * FreeDictUpdateInfo: releases memory * PrintDictUpdateInfo: none + * DisassembleDictUpdateInfo: none * *---------------------------------------------------------------------- */ @@ -2112,6 +2122,25 @@ PrintDictUpdateInfo( Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); } } + +static void +DisassembleDictUpdateInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + DictUpdateInfo *duiPtr = clientData; + int i; + Tcl_Obj *variables = Tcl_NewObj(); + + for (i=0 ; ilength ; i++) { + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewIntObj(duiPtr->varIndices[i])); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1), + variables); +} /* *---------------------------------------------------------------------- @@ -2856,10 +2885,10 @@ FreeForeachInfo( /* *---------------------------------------------------------------------- * - * PrintForeachInfo -- + * PrintForeachInfo, DisassembleForeachInfo -- * - * Function to write a human-readable representation of a ForeachInfo - * structure to stdout for debugging. + * Functions to write a human-readable or script-readablerepresentation + * of a ForeachInfo structure to a Tcl_Obj for debugging. * * Results: * None. @@ -2909,6 +2938,53 @@ PrintForeachInfo( Tcl_AppendToObj(appendObj, "]", -1); } } + +static void +DisassembleForeachInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + Tcl_Obj *objPtr, *innerPtr; + + /* + * Data stores. + */ + + objPtr = Tcl_NewObj(); + for (i=0 ; inumLists ; i++) { + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(infoPtr->firstValueTemp + i)); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr); + + /* + * Loop counter. + */ + + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1), + Tcl_NewIntObj(infoPtr->loopCtTemp)); + + /* + * Assignment targets. + */ + + objPtr = Tcl_NewObj(); + for (i=0 ; inumLists ; i++) { + innerPtr = Tcl_NewObj(); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; jnumVars ; j++) { + Tcl_ListObjAppendElement(NULL, innerPtr, + Tcl_NewIntObj(varsPtr->varIndexes[j])); + } + Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 855dd8f..3639032 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -27,6 +27,9 @@ static void FreeJumptableInfo(ClientData clientData); static void PrintJumptableInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleJumptableInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); @@ -74,7 +77,8 @@ const AuxDataType tclJumptableInfoType = { "JumptableInfo", /* name */ DupJumptableInfo, /* dupProc */ FreeJumptableInfo, /* freeProc */ - PrintJumptableInfo /* printProc */ + PrintJumptableInfo, /* printProc */ + DisassembleJumptableInfo /* disassembleProc */ }; /* @@ -1784,11 +1788,13 @@ IssueSwitchJumpTable( * DupJumptableInfo: a copy of the jump-table * FreeJumptableInfo: none * PrintJumptableInfo: none + * DisassembleJumptableInfo: none * * Side effects: * DupJumptableInfo: allocates memory * FreeJumptableInfo: releases memory * PrintJumptableInfo: none + * DisassembleJumptableInfo: none * *---------------------------------------------------------------------- */ @@ -1851,6 +1857,30 @@ PrintJumptableInfo( keyPtr, pcOffset + offset); } } + +static void +DisassembleJumptableInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register JumptableInfo *jtPtr = clientData; + Tcl_Obj *mapping = Tcl_NewObj(); + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + const char *keyPtr; + int offset; + + hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { + keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr); + offset = PTR2INT(Tcl_GetHashValue(hPtr)); + Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1), + Tcl_NewIntObj(offset)); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping); +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index f28403d..cf7b563 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -252,6 +252,16 @@ typedef struct AuxDataType { AuxDataPrintProc *printProc;/* Callback function to invoke when printing * the aux data as part of debugging. NULL * means that the data can't be printed. */ + AuxDataPrintProc *disassembleProc; + /* Callback function to invoke when doing a + * disassembly of the aux data (like the + * printProc, except that the output is + * intended to be script-readable). The + * appendObj argument should be filled in with + * a descriptive dictionary; it will start out + * with "name" mapped to the content of the + * name field. NULL means that the printProc + * should be used instead. */ } AuxDataType; /* diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 0d2b844..fa99eaf 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -928,24 +928,35 @@ DisassembleByteCodeAsDicts( case OPERAND_UINT1: val = TclGetUInt1AtPtr(opnd); opnd += 1; - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + if (*pc == INST_PUSH1) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "@%d", val)); + } else { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + } break; case OPERAND_UINT4: val = TclGetUInt4AtPtr(opnd); opnd += 4; - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + if (*pc == INST_PUSH4) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "@%d", val)); + } else { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + } break; case OPERAND_IDX4: val = TclGetInt4AtPtr(opnd); opnd += 4; if (val >= -1) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + ".%d", val)); } else if (val == -2) { Tcl_ListObjAppendElement(NULL, inst, - Tcl_NewStringObj("end", -1)); + Tcl_NewStringObj(".end", -1)); } else { Tcl_ListObjAppendElement(NULL, inst, - Tcl_ObjPrintf("end-%d", -2-val)); + Tcl_ObjPrintf(".end-%d", -2-val)); } break; case OPERAND_LVT1: @@ -984,9 +995,18 @@ DisassembleByteCodeAsDicts( AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); - if (auxData->type->printProc) { - Tcl_AppendToObj(auxDesc, " ", -1); - auxData->type->printProc(auxData->clientData, auxDesc, codePtr,0); + if (auxData->type->disassembleProc) { + Tcl_Obj *desc = Tcl_NewObj(); + + Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc); + auxDesc = desc; + auxData->type->disassembleProc(auxData->clientData, auxDesc, + codePtr, 0); + } else if (auxData->type->printProc) { + Tcl_Obj *desc = Tcl_NewObj(); + + auxData->type->printProc(auxData->clientData, desc, codePtr, 0); + Tcl_ListObjAppendElement(NULL, auxDesc, desc); } Tcl_ListObjAppendElement(NULL, aux, auxDesc); } -- cgit v0.12 From 9661fe86d98ed7175d60c3ebff7a06f4f5582ea3 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Mon, 17 Jun 2013 14:04:28 +0000 Subject: Remove extra scribblings not normally needed. Thanks to jdc for suggestion. --- generic/tclDisassemble.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index fa99eaf..7f0b11a 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -909,7 +909,7 @@ DisassembleByteCodeAsDicts( if (*pc == INST_JUMP1 || *pc == INST_JUMP_TRUE1 || *pc == INST_JUMP_FALSE1) { Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "pc %d (%d)", pc+val-codePtr->codeStart, val)); + "pc %d", pc+val-codePtr->codeStart)); } else { Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); } @@ -920,7 +920,7 @@ DisassembleByteCodeAsDicts( if (*pc == INST_JUMP4 || *pc == INST_JUMP_TRUE4 || *pc == INST_JUMP_FALSE4 || *pc == INST_START_CMD) { Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "pc %d (%d)", pc+val-codePtr->codeStart, val)); + "pc %d", pc+val-codePtr->codeStart)); } else { Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); } -- cgit v0.12 From 132c76a5dc5a5aac23f7678d07579b7424f34051 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Thu, 20 Jun 2013 11:05:20 +0000 Subject: Properly encode more operand types to reduce the number of special cases in the disassembler. --- generic/tclCompile.c | 18 +++--- generic/tclCompile.h | 8 ++- generic/tclDisassemble.c | 164 ++++++++++++++++++++++++++--------------------- 3 files changed, 106 insertions(+), 84 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 65fc218..aee711c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -55,9 +55,9 @@ InstructionDesc const tclInstructionTable[] = { /* Name Bytes stackEffect #Opnds Operand types */ {"done", 1, -1, 0, {OPERAND_NONE}}, /* Finish ByteCode execution and return stktop (top stack item) */ - {"push1", 2, +1, 1, {OPERAND_UINT1}}, + {"push1", 2, +1, 1, {OPERAND_LIT1}}, /* Push object at ByteCode objArray[op1] */ - {"push4", 5, +1, 1, {OPERAND_UINT4}}, + {"push4", 5, +1, 1, {OPERAND_LIT4}}, /* Push object at ByteCode objArray[op4] */ {"pop", 1, -1, 0, {OPERAND_NONE}}, /* Pop the topmost stack object */ @@ -125,17 +125,17 @@ InstructionDesc const tclInstructionTable[] = { {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr general variable; unparsed name is top, amount is op1 */ - {"jump1", 2, 0, 1, {OPERAND_INT1}}, + {"jump1", 2, 0, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) */ - {"jump4", 5, 0, 1, {OPERAND_INT4}}, + {"jump4", 5, 0, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpTrue1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ {"lor", 1, -1, 0, {OPERAND_NONE}}, @@ -298,7 +298,7 @@ InstructionDesc const tclInstructionTable[] = { /* List Index: push (lindex stktop op4) */ {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* List Range: push (lrange stktop op4 op4) */ - {"startCommand", 9, 0, 2, {OPERAND_INT4,OPERAND_UINT4}}, + {"startCommand", 9, 0, 2, {OPERAND_OFFSET4, OPERAND_UINT4}}, /* Start of bytecoded command: op is the length of the cmd's code, op2 * is number of commands here */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cf7b563..1f42b05 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -822,8 +822,14 @@ typedef enum InstOperandType { * variable table. */ OPERAND_LVT4, /* Four byte unsigned index into the local * variable table. */ - OPERAND_AUX4 /* Four byte unsigned index into the aux data + OPERAND_AUX4, /* Four byte unsigned index into the aux data * table. */ + OPERAND_OFFSET1, /* One byte signed jump offset. */ + OPERAND_OFFSET4, /* Four byte signed jump offset. */ + OPERAND_LIT1, /* One byte unsigned index into table of + * literals. */ + OPERAND_LIT4 /* Four byte unsigned index into table of + * literals. */ } InstOperandType; typedef struct InstructionDesc { diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 7f0b11a..c7072ee 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -482,42 +482,52 @@ FormatInstruction( switch (instDesc->opTypes[i]) { case OPERAND_INT1: opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 - || opCode == INST_JUMP_FALSE1) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 - || opCode == INST_JUMP_FALSE4) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } else if (opCode == INST_START_CMD) { - sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); - } Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_PUSH1) { - suffixObj = codePtr->objArrayPtr[opnd]; - } Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); break; - case OPERAND_AUX4: case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_PUSH4) { - suffixObj = codePtr->objArrayPtr[opnd]; - } else if (opCode == INST_START_CMD && opnd != 1) { + if (opCode == INST_START_CMD) { sprintf(suffixBuffer+strlen(suffixBuffer), ", %u cmds start here", opnd); } Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - if (instDesc->opTypes[i] == OPERAND_AUX4) { - auxPtr = &codePtr->auxDataArrayPtr[opnd]; + break; + case OPERAND_OFFSET1: + opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_OFFSET4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_START_CMD) { + sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); + } else { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); } + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_LIT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + suffixObj = codePtr->objArrayPtr[opnd]; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_LIT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + suffixObj = codePtr->objArrayPtr[opnd]; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_AUX4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + auxPtr = &codePtr->auxDataArrayPtr[opnd]; break; case OPERAND_IDX4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; @@ -896,54 +906,67 @@ DisassembleByteCodeAsDicts( instructions = Tcl_NewObj(); for (pc=codePtr->codeStart; pccodeStart+codePtr->numCodeBytes;){ const InstructionDesc *instDesc = &tclInstructionTable[*pc]; + int address = pc - codePtr->codeStart; inst = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, inst, - Tcl_NewStringObj(instDesc->name, -1)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( + instDesc->name, -1)); opnd = pc + 1; for (i=0 ; inumOperands ; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: val = TclGetInt1AtPtr(opnd); opnd += 1; - if (*pc == INST_JUMP1 || *pc == INST_JUMP_TRUE1 - || *pc == INST_JUMP_FALSE1) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "pc %d", pc+val-codePtr->codeStart)); - } else { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); - } - break; + goto formatNumber; + case OPERAND_UINT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + goto formatNumber; case OPERAND_INT4: val = TclGetInt4AtPtr(opnd); opnd += 4; - if (*pc == INST_JUMP4 || *pc == INST_JUMP_TRUE4 - || *pc == INST_JUMP_FALSE4 || *pc == INST_START_CMD) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "pc %d", pc+val-codePtr->codeStart)); - } else { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); - } + goto formatNumber; + case OPERAND_UINT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + formatNumber: + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); break; - case OPERAND_UINT1: + + case OPERAND_OFFSET1: + val = TclGetInt1AtPtr(opnd); + opnd += 1; + goto formatAddress; + case OPERAND_OFFSET4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + formatAddress: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "pc %d", address + val)); + break; + + case OPERAND_LIT1: val = TclGetUInt1AtPtr(opnd); opnd += 1; - if (*pc == INST_PUSH1) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "@%d", val)); - } else { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); - } + goto formatLiteral; + case OPERAND_LIT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + formatLiteral: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "@%d", val)); break; - case OPERAND_UINT4: + + case OPERAND_LVT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + goto formatVariable; + case OPERAND_LVT4: val = TclGetUInt4AtPtr(opnd); opnd += 4; - if (*pc == INST_PUSH4) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "@%d", val)); - } else { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); - } + formatVariable: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "%%%d", val)); break; case OPERAND_IDX4: val = TclGetInt4AtPtr(opnd); @@ -952,37 +975,24 @@ DisassembleByteCodeAsDicts( Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( ".%d", val)); } else if (val == -2) { - Tcl_ListObjAppendElement(NULL, inst, - Tcl_NewStringObj(".end", -1)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( + ".end", -1)); } else { - Tcl_ListObjAppendElement(NULL, inst, - Tcl_ObjPrintf(".end-%d", -2-val)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + ".end-%d", -2-val)); } break; - case OPERAND_LVT1: - val = TclGetUInt1AtPtr(opnd); - opnd += 1; - Tcl_ListObjAppendElement(NULL, inst, - Tcl_ObjPrintf("%%%d", val)); - break; - case OPERAND_LVT4: - val = TclGetUInt4AtPtr(opnd); - opnd += 4; - Tcl_ListObjAppendElement(NULL, inst, - Tcl_ObjPrintf("%%%d", val)); - break; case OPERAND_AUX4: val = TclGetInt4AtPtr(opnd); opnd += 4; - Tcl_ListObjAppendElement(NULL, inst, - Tcl_ObjPrintf("?%d", val)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "?%d", val)); break; case OPERAND_NONE: Tcl_Panic("opcode %d with more than zero 'no' operands", *pc); } } - Tcl_DictObjPut(NULL, instructions, - Tcl_NewIntObj(pc - codePtr->codeStart), inst); + Tcl_DictObjPut(NULL, instructions, Tcl_NewIntObj(address), inst); pc += instDesc->numBytes; } @@ -1039,18 +1049,23 @@ DisassembleByteCodeAsDicts( /* * Get the command information from the bytecode. + * + * The way these are encoded in the bytecode is non-trivial; the Decode + * macro (which updates its argument and returns the next decoded value) + * handles this so that the rest of the code does not. */ +#define Decode(ptr) \ + ((TclGetUInt1AtPtr(ptr) == 0xFF) \ + ? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4)) \ + : ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1))) + commands = Tcl_NewObj(); codeOffPtr = codePtr->codeDeltaStart; codeLenPtr = codePtr->codeLengthStart; srcOffPtr = codePtr->srcDeltaStart; srcLenPtr = codePtr->srcLengthStart; codeOffset = sourceOffset = 0; -#define Decode(ptr) \ - ((TclGetUInt1AtPtr(ptr) == 0xFF) \ - ? ((ptr)+=5,TclGetInt4AtPtr((ptr)-4)) \ - : ((ptr)+=1,TclGetInt1AtPtr((ptr)-1))) for (i=0 ; inumCommands ; i++) { Tcl_Obj *cmd; @@ -1077,6 +1092,7 @@ DisassembleByteCodeAsDicts( Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); Tcl_ListObjAppendElement(NULL, commands, cmd); } + #undef Decode /* -- cgit v0.12 From 1d7541ff9611935524a93135794f426f9a373313 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Sat, 8 Feb 2014 07:54:04 +0000 Subject: improve the testing of the disassembly commands --- tests/compile.test | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 81 insertions(+), 1 deletion(-) diff --git a/tests/compile.test b/tests/compile.test index 2852bf2..22ebc7d 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -658,12 +658,15 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup # does not check the format of disassembled bytecode though; that's liable to # change without warning. +set disassemblables [linsert [join { + lambda method objmethod proc script +} ", "] end-1 or] test compile-18.1 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble } -match glob -result {wrong # args: should be "*"} test compile-18.2 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble ? -} -match glob -result {bad type "?": must be *} +} -result "bad type \"?\": must be $disassemblables" test compile-18.3 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble lambda } -match glob -result {wrong # args: should be "* lambda lambdaTerm"} @@ -737,6 +740,83 @@ test compile-18.19 {disassembler - basics} -setup { } -cleanup { foo destroy } -match glob -result * +# There never was a compile-18.20. +# The keys of the dictionary produced by [getbytecode] are defined. +set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth} +test compile-18.21 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode +} -match glob -result {wrong # args: should be "*"} +test compile-18.22 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode ? +} -result "bad type \"?\": must be $disassemblables" +test compile-18.23 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode lambda +} -match glob -result {wrong # args: should be "* lambda lambdaTerm"} +test compile-18.24 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode lambda \{ +} -result "can't interpret \"\{\" as a lambda expression" +test compile-18.25 {disassembler - basics} -body { + dict keys [tcl::unsupported::getbytecode lambda {{} {}}] +} -result $bytecodekeys +test compile-18.26 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode proc +} -match glob -result {wrong # args: should be "* proc procName"} +test compile-18.27 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode proc nosuchproc +} -result {"nosuchproc" isn't a procedure} +test compile-18.28 {disassembler - basics} -setup { + proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result $bytecodekeys +test compile-18.29 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode script +} -match glob -result {wrong # args: should be "* script script"} +test compile-18.30 {disassembler - basics} -body { + dict keys [tcl::unsupported::getbytecode script {}] +} -result $bytecodekeys +test compile-18.31 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method +} -match glob -result {wrong # args: should be "* method className methodName"} +test compile-18.32 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method nosuchclass foo +} -result {nosuchclass does not refer to an object} +test compile-18.33 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::getbytecode method justanobject foo +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.34 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.35 {disassembler - basics} -setup { + oo::class create foo {method bar {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode method foo bar] +} -cleanup { + foo destroy +} -result $bytecodekeys +test compile-18.36 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod +} -match glob -result {wrong # args: should be "* objmethod objectName methodName"} +test compile-18.37 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod nosuchobject foo +} -result {nosuchobject does not refer to an object} +test compile-18.38 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.39 {disassembler - basics} -setup { + oo::object create foo + oo::objdefine foo {method bar {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode objmethod foo bar] +} -cleanup { + foo destroy +} -result $bytecodekeys test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { # This will panic in a --enable-symbols=compile build, unless bug is fixed. -- cgit v0.12 From f52377c98469f62827a0428fce112c8d264f03d4 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Mon, 28 Jul 2014 14:50:06 +0000 Subject: Bump to 8.6.2 for release. --- README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 8 files changed, 9 insertions(+), 9 deletions(-) diff --git a/README b/README index 7004bc5..66e1b76 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6.1 source distribution. + This is the Tcl 8.6.2 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index e557290..7531242 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 1 +#define TCL_RELEASE_SERIAL 2 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.1" +#define TCL_PATCH_LEVEL "8.6.2" /* *---------------------------------------------------------------------------- diff --git a/library/init.tcl b/library/init.tcl index bb17319..265f928 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6.1 +package require -exact Tcl 8.6.2 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index bd85ba4..ec5e0ed 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".1" +TCL_PATCH_LEVEL=".2" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/configure.in b/unix/configure.in index cb6cf82..85bd7ee 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".1" +TCL_PATCH_LEVEL=".2" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index 678222c..50aacc6 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6.1 +Version: 8.6.2 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index 2affd38..cf2b201 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".1" +TCL_PATCH_LEVEL=".2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index 77e0327..aa47505 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".1" +TCL_PATCH_LEVEL=".2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From e889981c04ef9e725a0503d868d290a6e64cfbcc Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Wed, 30 Jul 2014 16:41:24 +0000 Subject: [3757cdf808] More clock refactoring with spooky impact on [string match] performance. --- generic/tclClock.c | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 524a9e8..9d4bcd6 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -522,6 +522,26 @@ ClockGetdatefieldsObjCmd( */ static int +FetchEraField( + Tcl_Interp *interp, + Tcl_Obj *dict, + Tcl_Obj *key, + int *storePtr) +{ + Tcl_Obj *value = NULL; + + if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) { + return TCL_ERROR; + } + if (value == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "expected key(s) not found in dictionary", -1)); + return TCL_ERROR; + } + return Tcl_GetIndexFromObj(interp, value, eras, "era", TCL_EXACT, storePtr); +} + +static int FetchIntField( Tcl_Interp *interp, Tcl_Obj *dict, @@ -552,7 +572,6 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( Tcl_Obj *dict; ClockClientData *data = clientData; Tcl_Obj *const *literals = data->literals; - Tcl_Obj *fieldPtr; int changeover; int copied = 0; int status; @@ -567,10 +586,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( return TCL_ERROR; } dict = objv[1]; - if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK - || fieldPtr == NULL - || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, - &era) != TCL_OK + if (FetchEraField(interp, dict, literals[LIT_ERA], &era) != TCL_OK || FetchIntField(interp, dict, literals[LIT_YEAR], &fields.year) != TCL_OK || FetchIntField(interp, dict, literals[LIT_MONTH], &fields.month) @@ -640,7 +656,6 @@ ClockGetjuliandayfromerayearweekdayObjCmd( Tcl_Obj *dict; ClockClientData *data = clientData; Tcl_Obj *const *literals = data->literals; - Tcl_Obj *fieldPtr; int changeover; int copied = 0; int status; @@ -655,10 +670,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd( return TCL_ERROR; } dict = objv[1]; - if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK - || fieldPtr == NULL - || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, - &era) != TCL_OK + if (FetchEraField(interp, dict, literals[LIT_ERA], &era) != TCL_OK || FetchIntField(interp, dict, literals[LIT_ISO8601YEAR], &fields.iso8601Year) != TCL_OK || FetchIntField(interp, dict, literals[LIT_ISO8601WEEK], -- cgit v0.12 From 8ddb8b3cb45bf2770d9bfaa0d53f0685df4fd3a1 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Thu, 31 Jul 2014 19:58:53 +0000 Subject: [a84a720966] Protect against double free in TclOO classChainCache teardown. --- generic/tclOOCall.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 26fd09f..897f635 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -150,7 +150,7 @@ void TclOODeleteChain( CallChain *callPtr) { - if (--callPtr->refCount >= 1) { + if (callPtr == NULL || --callPtr->refCount >= 1) { return; } if (callPtr->chain != callPtr->staticChain) { -- cgit v0.12 From a8804d7cc0b7e092e32419f6483f925d75460828 Mon Sep 17 00:00:00 2001 From: "nijtmans@users.sourceforge.net" Date: Thu, 31 Jul 2014 21:23:45 +0000 Subject: Fix part of [d19aef1487] (broken --disable-load on MacOSX), broken by [4d417791c9] --- generic/tclLoadNone.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index c22c4c4..6cb4378 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -104,7 +104,9 @@ TclpLoadMemory( int size, /* Dummy: unused by this implementation */ int codeSize, /* Dummy: unused by this implementation */ Tcl_LoadHandle *loadHandle, /* Dummy: unused by this implementation */ - Tcl_FSUnloadFileProc **unloadProcPtr) + Tcl_FSUnloadFileProc **unloadProcPtr, + /* Dummy: unused by this implementation */ + int flags) /* Dummy: unused by this implementation */ { Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory " -- cgit v0.12 From 6a4b9125b49e7b6e456950f4ae288c25db9909e4 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 1 Aug 2014 14:36:30 +0000 Subject: Correction and commentary in the details of ensemble compiling. --- generic/tclEnsemble.c | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 022dafa..763f5a0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3019,8 +3019,24 @@ TclCompileEnsemble( cmdPtr = oldCmdPtr; depth--; } - (void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL); } + /* + * The length of the "replaced" list must be depth-1. Trim back + * any extra elements that might have been appended by failing + * pathways above. + */ + (void) Tcl_ListObjReplace(NULL, replaced, depth-1, INT_MAX, 0, NULL); + + /* + * TODO: Reconsider whether we ought to call CompileToInvokedCommand() + * when depth==1. In that case we are choosing to emit the + * INST_INVOKE_REPLACE bytecode when there is in fact no replacing + * to be done. It would be equally functional and presumably more + * performant to fall through to cleanup below, return TCL_ERROR, + * and let the compiler harness emit the INST_INVOKE_STK + * implementation for us. + */ + CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr); ourResult = TCL_OK; } -- cgit v0.12 From 1fef0fbfab65f6736441653e4f29f1d5700ce839 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 1 Aug 2014 16:01:30 +0000 Subject: [e75fabac06] Teardown line information after failed ensemble subcommand compile attempts. Copy/paste from CompileCmdCompileProc(). May be refactor opportunity here. --- generic/tclEnsemble.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 763f5a0..473c4bb 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2749,6 +2749,7 @@ TclCompileEnsemble( int ourResult = TCL_ERROR; unsigned numBytes; const char *word; + DefineLineInformation; Tcl_IncrRefCount(replaced); if (parsePtr->numWords < depth + 1) { @@ -3008,6 +3009,23 @@ TclCompileEnsemble( } /* + * Throw out any line information generated by the failed compile attempt. + */ + + while (mapPtr->nuloc - 1 > eclIndex) { + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; + } + + /* + * Reset the index of next command. Toss out any from failed nested + * partial compiles. + */ + + envPtr->numCommands = mapPtr->nuloc; + + /* * Failed to do a full compile for some reason. Try to do a direct invoke * instead of going through the ensemble lookup process again. */ -- cgit v0.12 From 3b1b6b4c02e3f90362b358a03b3c074da99cce4b Mon Sep 17 00:00:00 2001 From: andreask Date: Fri, 1 Aug 2014 20:07:40 +0000 Subject: Addition of a cast in tclWinFile.c to match types in a comparison, and fix of a TRACE string literal in tclExecute.c with a bogus escape. Both would otherwise bug a Windows debug build (where warnings are errors). --- generic/tclExecute.c | 2 +- win/tclWinFile.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2098e50..2e03ab4 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5079,7 +5079,7 @@ TEBCresume( valuePtr = OBJ_AT_TOS; opnd = TclGetInt4AtPtr(pc+1); - TRACE(("\%.30s\" %d => ", O2S(valuePtr), opnd)); + TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); /* * Get the contents of the list, making sure that it really is a list diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1cdd53f..fe84a26 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -2929,7 +2929,7 @@ TclNativeCreateNativeRep( str = Tcl_GetString(validPathPtr); len = validPathPtr->length; - if (strlen(str)!=len) { + if (strlen(str)!=(unsigned int)len) { /* String contains NUL-bytes. This is invalid. */ return 0; } -- cgit v0.12 From 22044c8704d292becdab6e0f347a6e2e9c8854a5 Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Sat, 2 Aug 2014 13:04:16 +0000 Subject: TIP 429 Implementation: [string cat] --- doc/string.n | 8 ++++++ generic/tclCmdMZ.c | 71 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclCompCmdsSZ.c | 33 +++++++++++++++++++++++ generic/tclInt.h | 3 +++ tests/string.test | 34 +++++++++++++++++++---- tests/stringComp.test | 38 ++++++++++++++++++++++++-- 6 files changed, 180 insertions(+), 7 deletions(-) diff --git a/doc/string.n b/doc/string.n index 72a69ff..9108e7c 100644 --- a/doc/string.n +++ b/doc/string.n @@ -19,6 +19,14 @@ string \- Manipulate strings Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP +\fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR? +. +Concatenate the given strings just like direct juxtaposition +would. This primitive is occasionally handier than juxtaposition when +mixed quoting is wanted, or when the aim is to return the result of a +concatenation without resorting to \fB[return -level 0]\fR. If no arg +is present, an empty string is returned. +.TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR . Perform a character-by-character comparison of strings \fIstring1\fR diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0f7f20a..ea5d7a4 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2838,6 +2838,76 @@ StringCmpCmd( /* *---------------------------------------------------------------------- * + * StringCatCmd -- + * + * This procedure is invoked to process the "string cat" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringCatCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int tot, i, length; + char *bytes, *p; + Tcl_Obj *objResultPtr; + + /* + * NOTE: this implementation aims for simplicity, not speed, because all + * speed-critical uses of [string cat] will involve the compiled variant + * anyway. Thus we avoid code duplication (from TEBC/INST_CONCAT1) without + * sacrificing perf. + */ + + if (objc < 2) { + /* + * If there are no args, the result is an empty object. + * Just leave the preset empty interp result. + */ + return TCL_OK; + } + tot = 0; + for(i = 1;i < objc;i++) { + bytes = TclGetStringFromObj(objv[i], &length); + if (bytes != NULL) { + tot += length; + } + } + if (tot < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + p = ckalloc(tot + 1); + TclNewObj(objResultPtr); + objResultPtr->bytes = p; + objResultPtr->length = tot; + for (i = 1;i < objc;i++) { + bytes = TclGetStringFromObj(objv[i], &length); + if (bytes != NULL) { + memcpy(p, bytes, (size_t) length); + p += length; + } + } + *p = '\0'; + Tcl_SetObjResult(interp,objResultPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * StringBytesCmd -- * * This procedure is invoked to process the "string bytelength" Tcl @@ -3330,6 +3400,7 @@ TclInitStringCmd( { static const EnsembleImplMap stringImplMap[] = { {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index e6ec0a6..8ade6a5 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -269,6 +269,39 @@ TclCompileSetCmd( */ int +TclCompileStringCatCmd( + 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. */ +{ + int numWords = parsePtr->numWords; + Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + + if (numWords>=2) { + int i; + + for (i = 1; i < numWords; i++) { + CompileWord(envPtr, wordTokenPtr, interp, i); + wordTokenPtr = TokenAfter(wordTokenPtr); + } + while (numWords > 256) { + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + numWords -= 254; /* concat pushes 1 obj, the result */ + } + if (numWords > 2) { + TclEmitInstInt1(INST_STR_CONCAT1, numWords - 1, envPtr); + } + } else { + PushStringLiteral(envPtr, ""); + } + return TCL_OK; +} + +int TclCompileStringCmpCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclInt.h b/generic/tclInt.h index 1bb2103..6bf1ef9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3646,6 +3646,9 @@ MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringCatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/tests/string.test b/tests/string.test index a8a83d9..54d02e8 100644 --- a/tests/string.test +++ b/tests/string.test @@ -30,7 +30,7 @@ testConstraint memory [llength [info commands memory]] test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2 {error conditions} { list [catch {string} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} @@ -54,7 +54,7 @@ test string-2.6 {string compare} { string compare abcde abdef } -1 test string-2.7 {string compare, shortest method name} { - string c abcde ABCDE + string co abcde ABCDE } 1 test string-2.8 {string compare} { string compare abcde abcde @@ -81,7 +81,7 @@ test string-2.13 {string compare -nocase} { string compare -nocase abcde abdef } -1 test string-2.14 {string compare -nocase} { - string c -nocase abcde ABCDE + string compare -nocase abcde ABCDE } 0 test string-2.15 {string compare -nocase} { string compare -nocase abcde abcde @@ -1513,7 +1513,7 @@ test string-20.1 {string trimright errors} { } {1 {wrong # args: should be "string trimright string ?chars?"}} test string-20.2 {string trimright errors} { list [catch {string trimg a} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3 {string trimright} { string trimright " XYZ " } { XYZ} @@ -1572,7 +1572,7 @@ test string-21.14 {string wordend, unicode} { test string-22.1 {string wordstart} { list [catch {string word a} msg] $msg -} {1 {unknown or ambiguous subcommand "word": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2 {string wordstart} { list [catch {string wordstart a} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} @@ -1969,6 +1969,30 @@ test string-28.13 {tcl::prefix longest} { tcl::prefix longest {ax\x90 bep ax\x91} a } ax +test string-29.1 {string cat, no arg} { + string cat +} "" +test string-29.2 {string cat, single arg} { + set x [pid] + string compare $x [string cat $x] +} 0 +test string-29.3 {string cat, two args} { + set x [pid] + string compare $x$x [string cat $x $x] +} 0 +test string-29.4 {string cat, many args} { + set x [pid] + set n 260 + set xx [string repeat $x $n] + set vv [string repeat {$x} $n] + set vvs [string repeat {$x } $n] + set r1 [string compare $xx [subst $vv]] + set r2 [string compare $xx [eval "string cat $vvs"]] + list $r1 $r2 +} {0 0} + + + # cleanup rename MemStress {} catch {rename foo {}} diff --git a/tests/stringComp.test b/tests/stringComp.test index 165ef20..083399b 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -46,7 +46,7 @@ if {[testConstraint memory]} { test stringComp-1.1 {error conditions} { proc foo {} {string gorp a b} list [catch {foo} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test stringComp-1.2 {error conditions} { proc foo {} {string} list [catch {foo} msg] $msg @@ -210,7 +210,7 @@ foreach {tname tbody tresult tcode} { # need a few extra tests short abbr cmd test stringComp-3.1 {string compare, shortest method name} { - proc foo {} {string c abcde ABCDE} + proc foo {} {string co abcde ABCDE} foo } 1 test stringComp-3.2 {string equal, shortest method name} { @@ -735,6 +735,40 @@ test stringComp-14.2 {Bug 82e7f67325} memory { ## string word* ## not yet bc + +## string cat +test stringComp-29.1 {string cat, no arg} { + proc foo {} {string cat} + foo +} "" +test stringComp-29.2 {string cat, single arg} { + proc foo {} { + set x [pid] + string compare $x [string cat $x] + } + foo +} 0 +test stringComp-29.3 {string cat, two args} { + proc foo {} { + set x [pid] + string compare $x$x [string cat $x $x] + } + foo +} 0 +test stringComp-29.4 {string cat, many args} { + proc foo {} { + set x [pid] + set n 260 + set xx [string repeat $x $n] + set vv [string repeat {$x} $n] + set vvs [string repeat {$x } $n] + set r1 [string compare $xx [subst $vv]] + set r2 [string compare $xx [eval "string cat $vvs"]] + list $r1 $r2 + } + foo +} {0 0} + # cleanup catch {rename foo {}} -- cgit v0.12 From 86d24e5a8cf71d776378b18e3604222d68ca0652 Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Sat, 2 Aug 2014 15:26:46 +0000 Subject: Don't use [pid] in tests, stick to constant literals. --- doc/string.n | 2 ++ tests/string.test | 6 +++--- tests/stringComp.test | 6 +++--- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/doc/string.n b/doc/string.n index 9108e7c..450a97b 100644 --- a/doc/string.n +++ b/doc/string.n @@ -19,6 +19,7 @@ string \- Manipulate strings Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP +.VS 8.6.2 \fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR? . Concatenate the given strings just like direct juxtaposition @@ -26,6 +27,7 @@ would. This primitive is occasionally handier than juxtaposition when mixed quoting is wanted, or when the aim is to return the result of a concatenation without resorting to \fB[return -level 0]\fR. If no arg is present, an empty string is returned. +.VE .TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR . diff --git a/tests/string.test b/tests/string.test index 54d02e8..3611753 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1973,15 +1973,15 @@ test string-29.1 {string cat, no arg} { string cat } "" test string-29.2 {string cat, single arg} { - set x [pid] + set x FOO string compare $x [string cat $x] } 0 test string-29.3 {string cat, two args} { - set x [pid] + set x FOO string compare $x$x [string cat $x $x] } 0 test string-29.4 {string cat, many args} { - set x [pid] + set x FOO set n 260 set xx [string repeat $x $n] set vv [string repeat {$x} $n] diff --git a/tests/stringComp.test b/tests/stringComp.test index 083399b..f9f6bda 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -743,21 +743,21 @@ test stringComp-29.1 {string cat, no arg} { } "" test stringComp-29.2 {string cat, single arg} { proc foo {} { - set x [pid] + set x FOO string compare $x [string cat $x] } foo } 0 test stringComp-29.3 {string cat, two args} { proc foo {} { - set x [pid] + set x FOO string compare $x$x [string cat $x $x] } foo } 0 test stringComp-29.4 {string cat, many args} { proc foo {} { - set x [pid] + set x FOO set n 260 set xx [string repeat $x $n] set vv [string repeat {$x} $n] -- cgit v0.12 From 01489f4c2e4824ed75c12684bc8f4fd5df41e4ec Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Sun, 3 Aug 2014 22:43:42 +0000 Subject: Tidy up the docs --- doc/string.n | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/doc/string.n b/doc/string.n index 450a97b..33780ff 100644 --- a/doc/string.n +++ b/doc/string.n @@ -19,14 +19,19 @@ string \- Manipulate strings Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP -.VS 8.6.2 \fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR? -. -Concatenate the given strings just like direct juxtaposition -would. This primitive is occasionally handier than juxtaposition when -mixed quoting is wanted, or when the aim is to return the result of a -concatenation without resorting to \fB[return -level 0]\fR. If no arg -is present, an empty string is returned. +.VS 8.6.2 +Concatenate the given \fIstring\fRs just like placing them directly +next to each other and return the resulting compound string. If no +\fIstring\fRs are present, the result is an empty string. +.RS +.PP +This primitive is occasionally handier than juxtaposition of strings +when mixed quoting is wanted, or when the aim is to return the result +of a concatenation without resorting to \fBreturn\fR \fB\-level 0\fR, +and is more efficient than building a list of arguments and using +\fBjoin\fR with an empty join string. +.RE .VE .TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR -- cgit v0.12 From ca2aff8fcca9b377ee780d01f782b2b6e24f4c22 Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Tue, 5 Aug 2014 09:55:54 +0000 Subject: More optimized non-BC [string cat] using Tcl_AppendObjToObj() - thx Donal --- generic/tclCmdMZ.c | 45 ++++++++++++++------------------------------- 1 file changed, 14 insertions(+), 31 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index ea5d7a4..841002f 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2859,17 +2859,9 @@ StringCatCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tot, i, length; - char *bytes, *p; + int i; Tcl_Obj *objResultPtr; - /* - * NOTE: this implementation aims for simplicity, not speed, because all - * speed-critical uses of [string cat] will involve the compiled variant - * anyway. Thus we avoid code duplication (from TEBC/INST_CONCAT1) without - * sacrificing perf. - */ - if (objc < 2) { /* * If there are no args, the result is an empty object. @@ -2877,30 +2869,21 @@ StringCatCmd( */ return TCL_OK; } - tot = 0; - for(i = 1;i < objc;i++) { - bytes = TclGetStringFromObj(objv[i], &length); - if (bytes != NULL) { - tot += length; - } + if (objc == 2) { + /* + * Other trivial case, single arg, just return it. + */ + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } - if (tot < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - p = ckalloc(tot + 1); - TclNewObj(objResultPtr); - objResultPtr->bytes = p; - objResultPtr->length = tot; - for (i = 1;i < objc;i++) { - bytes = TclGetStringFromObj(objv[i], &length); - if (bytes != NULL) { - memcpy(p, bytes, (size_t) length); - p += length; - } + objResultPtr = objv[1]; + if (Tcl_IsShared(objResultPtr)) { + objResultPtr = Tcl_DuplicateObj(objResultPtr); + } + for(i = 2;i < objc;i++) { + Tcl_AppendObjToObj(objResultPtr, objv[i]); } - *p = '\0'; - Tcl_SetObjResult(interp,objResultPtr); + Tcl_SetObjResult(interp, objResultPtr); return TCL_OK; } -- cgit v0.12 From d738b4704f619da7ed05dc55a5f889e56f99145a Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Tue, 5 Aug 2014 10:34:10 +0000 Subject: Add constant folding to [string cat]. Mixed-quote idiom is now compiled to a single push. --- generic/tclCompCmdsSZ.c | 62 ++++++++++++++++++++++++++++++++++++------------- 1 file changed, 46 insertions(+), 16 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8ade6a5..bd8b463 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -277,27 +277,57 @@ TclCompileStringCatCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int numWords = parsePtr->numWords; - Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + int i,numWords = parsePtr->numWords; + Tcl_Token *wordTokenPtr; + Tcl_Obj *obj, *folded; DefineLineInformation; /* TIP #280 */ - if (numWords>=2) { - int i; + /* Trivial case, no arg */ - for (i = 1; i < numWords; i++) { - CompileWord(envPtr, wordTokenPtr, interp, i); - wordTokenPtr = TokenAfter(wordTokenPtr); - } - while (numWords > 256) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); - numWords -= 254; /* concat pushes 1 obj, the result */ - } - if (numWords > 2) { - TclEmitInstInt1(INST_STR_CONCAT1, numWords - 1, envPtr); - } - } else { + if (numWords<2) { PushStringLiteral(envPtr, ""); + return TCL_OK; } + + /* Detection of foldable constants. Often used for mixed quoting. */ + + folded = Tcl_NewObj(); + wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i = 1; i < numWords; i++) { + obj = Tcl_NewObj(); + if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) { + Tcl_AppendObjToObj(folded, obj); + } else { + Tcl_DecrRefCount(obj); + Tcl_DecrRefCount(folded); + folded = NULL; + break; + } + wordTokenPtr = TokenAfter(wordTokenPtr); + } + if (folded) { + int len; + const char *bytes = Tcl_GetStringFromObj(folded, &len); + + PushLiteral(envPtr, bytes, len); + return TCL_OK; + } + + /* General case: just issue CONCAT1's (by chunks of 255 if needed) */ + + wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i = 1; i < numWords; i++) { + CompileWord(envPtr, wordTokenPtr, interp, i); + wordTokenPtr = TokenAfter(wordTokenPtr); + } + while (numWords > 256) { + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + numWords -= 254; /* concat pushes 1 obj, the result */ + } + if (numWords > 2) { + TclEmitInstInt1(INST_STR_CONCAT1, numWords - 1, envPtr); + } + return TCL_OK; } -- cgit v0.12 From 3308e04cc88f738c7f1c40729edf4d75bf0abd61 Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Tue, 5 Aug 2014 11:29:16 +0000 Subject: Better organize [string cat] by chunks of 255 args. --- generic/tclCompCmdsSZ.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index bd8b463..87b1ebb 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -277,7 +277,7 @@ TclCompileStringCatCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int i,numWords = parsePtr->numWords; + int i, numWords = parsePtr->numWords, numArgs; Tcl_Token *wordTokenPtr; Tcl_Obj *obj, *folded; DefineLineInformation; /* TIP #280 */ @@ -315,17 +315,19 @@ TclCompileStringCatCmd( /* General case: just issue CONCAT1's (by chunks of 255 if needed) */ + numArgs = 0; wordTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { CompileWord(envPtr, wordTokenPtr, interp, i); + numArgs ++; + if (numArgs == 255) { + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + numArgs = 1; /* concat pushes 1 obj, the result */ + } wordTokenPtr = TokenAfter(wordTokenPtr); } - while (numWords > 256) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); - numWords -= 254; /* concat pushes 1 obj, the result */ - } - if (numWords > 2) { - TclEmitInstInt1(INST_STR_CONCAT1, numWords - 1, envPtr); + if (numArgs > 1) { + TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); } return TCL_OK; -- cgit v0.12 From ff6bf3230ff9fd2c627f570a683f6cecda78e3eb Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Tue, 5 Aug 2014 18:20:48 +0000 Subject: More aggressive constant folding in [string cat]. Thanks AndreasK for kicking. --- generic/tclCompCmdsSZ.c | 47 +++++++++++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 87b1ebb..fb26430 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -289,19 +289,38 @@ TclCompileStringCatCmd( return TCL_OK; } - /* Detection of foldable constants. Often used for mixed quoting. */ + /* General case: issue CONCAT1's (by chunks of 255 if needed), folding + contiguous constants along the way */ - folded = Tcl_NewObj(); + numArgs = 0; + folded = NULL; wordTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { obj = Tcl_NewObj(); if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) { - Tcl_AppendObjToObj(folded, obj); + if (folded) { + Tcl_AppendObjToObj(folded, obj); + Tcl_DecrRefCount(obj); + } else { + folded = obj; + } } else { Tcl_DecrRefCount(obj); - Tcl_DecrRefCount(folded); - folded = NULL; - break; + if (folded) { + int len; + const char *bytes = Tcl_GetStringFromObj(folded, &len); + + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(folded); + folded = NULL; + numArgs ++; + } + CompileWord(envPtr, wordTokenPtr, interp, i); + numArgs ++; + if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */ + TclEmitInstInt1(INST_STR_CONCAT1, 254, envPtr); + numArgs -= 253; /* concat pushes 1 obj, the result */ + } } wordTokenPtr = TokenAfter(wordTokenPtr); } @@ -310,21 +329,9 @@ TclCompileStringCatCmd( const char *bytes = Tcl_GetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); - return TCL_OK; - } - - /* General case: just issue CONCAT1's (by chunks of 255 if needed) */ - - numArgs = 0; - wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i = 1; i < numWords; i++) { - CompileWord(envPtr, wordTokenPtr, interp, i); + Tcl_DecrRefCount(folded); + folded = NULL; numArgs ++; - if (numArgs == 255) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); - numArgs = 1; /* concat pushes 1 obj, the result */ - } - wordTokenPtr = TokenAfter(wordTokenPtr); } if (numArgs > 1) { TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); -- cgit v0.12 From 6b407167766ccac59ee46a1c659cbd78a048d957 Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Tue, 5 Aug 2014 22:10:58 +0000 Subject: Fix comment inaccuracy. --- generic/tclCompCmdsSZ.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index fb26430..f2e5dd2 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -289,7 +289,7 @@ TclCompileStringCatCmd( return TCL_OK; } - /* General case: issue CONCAT1's (by chunks of 255 if needed), folding + /* General case: issue CONCAT1's (by chunks of 254 if needed), folding contiguous constants along the way */ numArgs = 0; -- cgit v0.12 From fb396e7fb59a889d72af7fb8e8ec813eaacdcbae Mon Sep 17 00:00:00 2001 From: andreask Date: Wed, 6 Aug 2014 18:20:56 +0000 Subject: Fixed type conversion warnings which break a Win32 debug build (MSVC). --- generic/tclIO.c | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index c142917..66c0be6 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9048,7 +9048,8 @@ MBWrite( ChannelState *outStatePtr = csPtr->writePtr->state; ChannelBuffer *bufPtr = inStatePtr->inQueueHead; ChannelBuffer *tail = NULL; - int code, inBytes = 0; + int code; + Tcl_WideInt inBytes = 0; /* Count up number of bytes waiting in the input queue */ while (bufPtr) { @@ -9063,7 +9064,14 @@ MBWrite( if (bufPtr) { /* Split the overflowing buffer in two */ - int extra = inBytes - csPtr->toRead; + int extra = (int) (inBytes - csPtr->toRead); + /* Note that going with int for extra assumes that inBytes is not too + * much over toRead to require a wide itself. If that gets violated + * then the calculations involving extra must be made wide too. + * + * Noted with Win32/MSVC debug build treating the warning (possible of + * data in int64 to int conversion) as error. + */ bufPtr = AllocChannelBuffer(extra); -- cgit v0.12 From 1781a9d5fc8e8d7912afdbf7f620ea3fd89947e6 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Sun, 17 Aug 2014 15:23:49 +0000 Subject: [7d52e1101b] oo::object should know that oo::class is a subclass. --- generic/tclOO.c | 1 + tests/oo.test | 17 +++++++++++++++++ 2 files changed, 18 insertions(+) diff --git a/generic/tclOO.c b/generic/tclOO.c index 02e00c9..ace47fe 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -394,6 +394,7 @@ InitFoundation( fPtr->classCls->flags |= ROOT_CLASS; TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); AddRef(fPtr->objectCls->thisPtr); AddRef(fPtr->objectCls); diff --git a/tests/oo.test b/tests/oo.test index fcd9818..8c515da 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -283,6 +283,23 @@ test oo-1.20 {basic test of OO functionality: my teardown post rename} -body { obj destroy info commands ::AGlobalName } -result {} +test oo-1.21 {basic test of OO functionality: default relations} -setup { + set fresh [interp create] +} -body { + lmap x [$fresh eval { + foreach cmd {instances subclasses mixins superclass} { + foreach initial {object class Slot} { + lappend x [info class $cmd ::oo::$initial] + } + } + foreach initial {object class Slot} { + lappend x [info object class ::oo::$initial] + } + return $x + }] {lsort $x} +} -cleanup { + interp delete $fresh +} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as -- cgit v0.12 From cf149348b042790114e077df48f3e8abda424f88 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Tue, 19 Aug 2014 18:34:09 +0000 Subject: Update changes file. --- changes | 146 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 144 insertions(+), 2 deletions(-) diff --git a/changes b/changes index 659319c..ab01bed 100644 --- a/changes +++ b/changes @@ -8274,7 +8274,7 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) 2013-08-01 (bug fix)[1905562] RE recursion limit increased to support reported usage of large expressions (porter) -2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows)2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows) +2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows) 2013-08-03 (enhancement)[3611643] [auto_mkindex] support TclOO (fellows) @@ -8303,4 +8303,146 @@ reported usage of large expressions (porter) Many optmizations, improvements, and tightened stack management in bytecode. ---- Released 8.6.1, Septemer 20, 2013 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.1, September 20, 2013 --- http://core.tcl.tk/tcl/ for details + +2013-09-27 (enhancement) improved ::env synchronization (fellows) + +2013-10-20 (bug fix)[2835313] segfault from +[apply {{} {while 1 {a {*}[return -level 0 -code continue]}}}] (fellows) + +2013-10-22 (bug fix)[3556215] [scan %E%G%X] support (fellows) + +2013-10-25 (bug fix)[3eb2ec1] upper case scheme names in url. (nijtmans) +=> http 2.8.8 + +2013-10-29 (bug fix)[414d103] HP-UX: restore [exec] in threaded Tcl (nijtmans) + +2013-11-04 (bug fix) C++ friendly stubs struct declarations (nijtmans) + +2013-11-05 (bug fix)[426679e] OpenBSD man page rendering (nijtmans) + +2013-11-12 (bug fix)[5425f2c] [fconfigure -error] breaks [socket -async] + +2013-11-20 (bug fix) Improved environment variable management (nijtmans) +=> tcltest 2.3.7 + +2013-11-21 (platforms) Support for Windows 8.1 (nijtmans) + +2013-12-06 (RFE) improved [foreach] bytecode (fellows) + +2013-12-10 (RFE) improved [lmap] bytecode (sofer) + +2013-12-11 (RFE) improved [catch] bytecode (sofer) + +2013-12-18 (bug fix)[0b874c3] SEGV [coroutine X coroutine Y info frame] (porter) + +2013-12-20 (RFE) reduced numeric conversion in bytecode (sofer) + +2014-01-07 (RFE) compilers for [concat], [linsert], [namespace origin], +[next], [string replace], [string tolower], [string totitle], [string toupper], +[string trim], [string trimleft], [string trimright] (fellows) + +2014-01-22 (RFE) compilers for [nextto], [yieldto] (fellows) + +2014-02-02 (RFE) compiler for [string is] (fellows) + +2014-02-06 (bug fix)[a4494e2] panic in test namespace-13.2 (porter) + +2014-03-20 (bug fix)[2f7cbd0] FreeBSD 10.0 build failure (nijtmans) + +2014-03-26 (RFE)[b42b208] Cygwin: [file attr -readonly -archive -hidden -system] +(nijtmans) + +2014-03-27 (bug fix) segfault iocmd-23.11 (porter) + +2014-04-04 (bug fix)[581937a,97069ea] async socket connect fail (oehlmann) + +2014-04-10 (bug fix)[792641f] Win: no \ in normalized path (nijtmans) + +2014-04-11 (bug fix)[3118489] protect NUL in filenames (nijtmans) + +2014-04-15 (bug fix)[88aef05] segfault iocmd-21.20 (porter) + +2014-04-16 (update) Win: use Winsock 2.2 (nijtmans) + +2014-04-16 (bug fix)[d19a30d] segfault clock-67.[23] (sebres) + +2014-04-21 (bug fix) segfault iocmd-21.2[12] (porter) + +2014-04-22 (bug fix) segfault iogt-2.4 (porter) + +2014-04-23 (bug fix)[3493120] memleak in thread exit + +2014-05-08 refactoring of core I/O functions (porter) + +2014-05-09 (bug fix)[3389978] Win: extended paths support (nijtmans) + +2014-05-09 (bug fix) segfault iocmd-32.1 (porter) + +2014-05-11 (bug fix)[6d2f249] nested ensemble compile failure (fellows) + +2014-05-17 (RFE)[47d6625] wideint support in [lsearch -integer] [lsort -integer] (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2014-05-20 (bug fix) Stop eof and blocked state leaking thru stacks (porter) + *** POTENTIAL INCOMPATIBILITY *** + +2014-05-28 (platforms) work around systems that fail when a shared library +is deleted after it is [load]ed (kupries) + +2014-05-31 (bug fix) chan events on pipes must be on proper ends (porter) + +2014-06-04 (bug fix) socket-2.12 (porter) + +2014-06-05 (bug fix) io-12.6 (kupries,porter) + +2014-06-15 (RFE)[1b0266d] [dict replace|remove] return canonical dict (fellows) + *** POTENTIAL INCOMPATIBILITY *** + +2014-06-16 (bug fix) socket-2.13 workaround broken select() (porter) + +2014-06-20 (bug fix)[b47b176] iortrans.tf-11.0 (porter) + +2014-06-22 (RFE)[2f9df4c] -cleanup scripts before -out compare (nijtmans) + +2014-07-04 (update) Update Unicode data to 7.0 (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2014-07-08 (bug) [chan push] converts blocked writes to error (aspect,porter) + +2014-07-10 (bug fix)[7368d2] memleak Tcl_SetVar2(..,TCL_APPEND_VALUE) (porter) + *** POTENTIAL INCOMPATIBILITY *** + +2014-07-11 (bug) leaks in SetFsPathFromAny, [info frame] (porter) + +2014-07-15 (bug) compress dict leak in zlib xform channel close (porter) + +2014-07-17 (bug fix)[9969cf8] leak trace data in coroutine deletion (porter) + +2014-07-18 (RFE)[b43f2b4] fix [lappend] multi performance collapse (fellows) + +2014-07-19 (bug fix)[75b8433] memleak managing oo instance lists (porter) + +2014-07-21 (bug fix)[e6477e1] memleak in AtForkChild() (porter) + +2014-07-22 (bug fix)[12b0997] memleak in iocmd.tf-32.0 (porter) + +2014-07-28 (RFE) Optimized binary [chan copy] by moving buffers (porter) + +2014-07-30 (enhancement) use refcounts, not Tcl_Preserve to manage lifetime +of Tcl_Channel (porter) + *** POTENTIAL INCOMPATIBILITY *** + +2014-07-31 (bug fix)[a84a720] double free in oo chain deletion (porter) + +2014-08-01 (bug fix)[e75faba] SEGV [apply {{} {namespace upvar a b [x]}}] (porter) + +2014-08-01 (update) "macosx*-i386-x86_64" "macosx-universal" no longer compatible (kupries) +=> platform 1.0.13 + +2014-08-12 tzdata updated to Olson's tzdata2014f (kenny) + +2014-08-17 (bug fix)[7d52e11] [info class subclasses oo::object] should +include ::oo::class (fellows) + +--- Released 8.6.2, August, 2014 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From 397a6411bfba62a5f95257e9a9dac3edb269931d Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Wed, 20 Aug 2014 14:28:36 +0000 Subject: Additions to changes. --- changes | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/changes b/changes index ab01bed..6cf3321 100644 --- a/changes +++ b/changes @@ -8355,6 +8355,8 @@ Many optmizations, improvements, and tightened stack management in bytecode. 2014-03-27 (bug fix) segfault iocmd-23.11 (porter) +2014-04-02 (bug fix)[581937a] Win: readable event on async connect failure + 2014-04-04 (bug fix)[581937a,97069ea] async socket connect fail (oehlmann) 2014-04-10 (bug fix)[792641f] Win: no \ in normalized path (nijtmans) @@ -8387,6 +8389,8 @@ Many optmizations, improvements, and tightened stack management in bytecode. 2014-05-20 (bug fix) Stop eof and blocked state leaking thru stacks (porter) *** POTENTIAL INCOMPATIBILITY *** +2014-05-20 (bug fix)[13d3af3] Win: socket -async tried only first IP address + 2014-05-28 (platforms) work around systems that fail when a shared library is deleted after it is [load]ed (kupries) -- cgit v0.12 From 41c4aa7987f4e1317c688ba3778318ac65e55929 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 22 Aug 2014 21:52:37 +0000 Subject: Bump to TclOO 1.0.2 --- generic/tclOO.h | 2 +- unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclOO.h b/generic/tclOO.h index a6e8a22..24d3e6f 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,7 +24,7 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0.1" +#define TCLOO_VERSION "1.0.2" #define TCLOO_PATCHLEVEL TCLOO_VERSION #include "tcl.h" diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 08cc4c5..14b0d8d 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0.1 +TCLOO_VERSION=1.0.2 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 08cc4c5..14b0d8d 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0.1 +TCLOO_VERSION=1.0.2 -- cgit v0.12 From 66e7ca859695d5cbc5748284956e5c5393431b0b Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 22 Aug 2014 22:11:13 +0000 Subject: Bump to zlib 2.0.1. --- generic/tclZlib.c | 2 +- tests/zlib.test | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 06e18fe..956e3f9 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -26,7 +26,7 @@ * interface, even if that is mostly true). */ -#define TCL_ZLIB_VERSION "2.0" +#define TCL_ZLIB_VERSION "2.0.1" /* * Magic flags used with wbits fields to indicate that we're handling the gzip diff --git a/tests/zlib.test b/tests/zlib.test index 2346ec7..b1d43fb 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -35,7 +35,7 @@ test zlib-1.3 {zlib basics} -constraints zlib -body { } -result zlibVersion test zlib-1.4 {zlib basics} -constraints zlib -body { package present zlib -} -result 2.0 +} -result 2.0.1 test zlib-2.1 {zlib compress/decompress} zlib { zlib decompress [zlib compress abcdefghijklm] -- cgit v0.12 From eb3b02f5fa431a288fcf0a4c04d9037fde7a2bac Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Mon, 25 Aug 2014 13:51:31 +0000 Subject: Do not let fossil README droppings leak into distribuion --- unix/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 1b2ccf1..0d9b9f0 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1975,7 +1975,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic - cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README* \ + cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README \ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \ $(DISTDIR) @mkdir $(DISTDIR)/library -- cgit v0.12 From 2f8d24c23c0c2c1df3298efc7922d423fb6dc961 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Thu, 28 Aug 2014 07:53:24 +0000 Subject: [b9e1a3032e] Implement the documented method search order for TclOO. This corrects the relative positions of object-defined methods and class mixins. --- generic/tclOOCall.c | 97 +++++++++++++++++++++++++++++++++++++++-------------- tests/ooNext2.test | 87 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 158 insertions(+), 26 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 897f635..2a81091 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -38,6 +38,12 @@ struct ChainBuilder { #define DEFINITE_PUBLIC 0x200000 #define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC) #define SPECIAL (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN) +#define BUILDING_MIXINS 0x400000 +#define TRAVERSED_MIXIN 0x800000 +#define OBJECT_MIXIN 0x1000000 +#define MIXIN_CONSISTENT(flags) \ + (((flags) & OBJECT_MIXIN) || \ + !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) /* * Function declarations for things defined in this file. @@ -45,13 +51,13 @@ struct ChainBuilder { static void AddClassFiltersToCallContext(Object *const oPtr, Class *clsPtr, struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters); + Tcl_HashTable *const doneFilters, int flags); static void AddClassMethodNames(Class *clsPtr, const int flags, Tcl_HashTable *const namesPtr); static inline void AddMethodToCallChain(Method *const mPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, - Class *const filterDecl); + Class *const filterDecl, int flags); static inline void AddSimpleChainToCallContext(Object *const oPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, @@ -434,7 +440,7 @@ TclOOGetSortedMethodList( AddClassMethodNames(oPtr->selfCls, flags, &names); FOREACH(mixinPtr, oPtr->mixins) { - AddClassMethodNames(mixinPtr, flags, &names); + AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names); } /* @@ -598,7 +604,7 @@ AddClassMethodNames( /* TODO: Beware of infinite loops! */ FOREACH(mixinPtr, clsPtr->mixins) { - AddClassMethodNames(mixinPtr, flags, namesPtr); + AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, namesPtr); } } @@ -695,13 +701,13 @@ AddSimpleChainToCallContext( FOREACH(mixinPtr, oPtr->mixins) { AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); } if (oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); if (hPtr != NULL) { AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr, - doneFilters, filterDecl); + doneFilters, filterDecl, flags); } } } @@ -732,9 +738,15 @@ AddMethodToCallChain( * processed. If NULL, not processing filters. * Note that this function does not update * this hashtable. */ - Class *const filterDecl) /* The class that declared the filter. If + Class *const filterDecl, /* The class that declared the filter. If * NULL, either the filter was declared by the * object or this isn't a filter. */ + int flags) /* Used to check if we're mixin-consistent + * only. Mixin-consistent means that either + * we're looking to add things from a mixin + * and we have passed a mixin, or we're not + * looking to add things from a mixin and have + * not passed a mixin. */ { register CallChain *callPtr = cbPtr->callChainPtr; int i; @@ -743,9 +755,11 @@ AddMethodToCallChain( * Return if this is just an entry used to record whether this is a public * method. If so, there's nothing real to call and so nothing to add to * the call chain. + * + * This is also where we enforce mixin-consistency. */ - if (mPtr == NULL || mPtr->typePtr == NULL) { + if (mPtr == NULL || mPtr->typePtr == NULL || !MIXIN_CONSISTENT(flags)) { return; } @@ -1001,6 +1015,8 @@ TclOOGetCallContext( if (flags & FORCE_UNKNOWN) { AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; @@ -1024,21 +1040,32 @@ TclOOGetCallContext( doFilters = 1; Tcl_InitObjHashTable(&doneFilters); FOREACH(mixinPtr, oPtr->mixins) { - AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters); + AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters, + TRAVERSED_MIXIN|BUILDING_MIXINS|OBJECT_MIXIN); + AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters, + OBJECT_MIXIN); } FOREACH(filterObj, oPtr->filters) { + AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, + BUILDING_MIXINS, NULL); AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, NULL); } - AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters); + AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, + BUILDING_MIXINS); + AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, + 0); Tcl_DeleteHashTable(&doneFilters); } count = cb.filterLength = callPtr->numChain; /* - * Add the actual method implementations. + * Add the actual method implementations. We have to do this twice to + * handle class mixins right. */ + AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, + flags|BUILDING_MIXINS, NULL); AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); /* @@ -1058,6 +1085,8 @@ TclOOGetCallContext( return NULL; } AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; @@ -1201,7 +1230,9 @@ TclOOGetStereotypeCallChain( */ Tcl_InitObjHashTable(&doneFilters); - AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters); + AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters, + BUILDING_MIXINS); + AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters, 0); Tcl_DeleteHashTable(&doneFilters); count = cb.filterLength = callPtr->numChain; @@ -1209,6 +1240,8 @@ TclOOGetStereotypeCallChain( * Add the actual method implementations. */ + AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, + flags|BUILDING_MIXINS, NULL); AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); /* @@ -1219,6 +1252,8 @@ TclOOGetStereotypeCallChain( if (count == callPtr->numChain) { AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, + NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; @@ -1259,12 +1294,15 @@ AddClassFiltersToCallContext( Class *clsPtr, /* Class to get the filters from. */ struct ChainBuilder *const cbPtr, /* Context to fill with call chain entries. */ - Tcl_HashTable *const doneFilters) + Tcl_HashTable *const doneFilters, /* Where to record what filters have been * processed. Keys are objects, values are * ignored. */ + int flags) /* Whether we've gone along a mixin link + * yet. */ { - int i; + int i, clearedFlags = + flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS); Class *superPtr, *mixinPtr; Tcl_Obj *filterObj; @@ -1279,7 +1317,8 @@ AddClassFiltersToCallContext( */ FOREACH(mixinPtr, clsPtr->mixins) { - AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters); + AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters, + flags|TRAVERSED_MIXIN); } /* @@ -1288,13 +1327,18 @@ AddClassFiltersToCallContext( * override how filters work to extend their behaviour. */ - FOREACH(filterObj, clsPtr->filters) { - int isNew; + if (MIXIN_CONSISTENT(flags)) { + FOREACH(filterObj, clsPtr->filters) { + int isNew; - (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); - if (isNew) { - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, doneFilters, - 0, clsPtr); + (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, + &isNew); + if (isNew) { + AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); + AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + doneFilters, clearedFlags, clsPtr); + } } } @@ -1308,7 +1352,8 @@ AddClassFiltersToCallContext( goto tailRecurse; default: FOREACH(superPtr, clsPtr->superclasses) { - AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters); + AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters, + flags); } case 0: return; @@ -1355,16 +1400,16 @@ AddSimpleClassChainToCallContext( tailRecurse: FOREACH(superPtr, classPtr->mixins) { AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); } if (flags & CONSTRUCTOR) { AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters, - filterDecl); + filterDecl, flags); } else if (flags & DESTRUCTOR) { AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters, - filterDecl); + filterDecl, flags); } else { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, (char *) methodNameObj); @@ -1383,7 +1428,7 @@ AddSimpleClassChainToCallContext( flags |= DEFINITE_PROTECTED; } } - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl); + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } } diff --git a/tests/ooNext2.test b/tests/ooNext2.test index a47aa91..9a63577 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -526,6 +526,93 @@ test oo-call-1.19 {object call introspection - memory leaks} -setup { } -cleanup { leaktester destroy } -constraints memory -result 0 +test oo-call-1.20 {object call introspection - complex case} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + oo::class create ::C { + superclass root + method x {} {} + mixin B + } + oo::class create ::D { + superclass C + method x {} {} + } + oo::class create ::E { + superclass root + method x {} {} + } + oo::class create ::F { + superclass E + method x {} {} + } + oo::class create ::G { + superclass root + method x {} {} + } + oo::class create ::H { + superclass G + method x {} {} + } + oo::define F mixin H + F create y + oo::objdefine y { + method x {} {} + mixin D + } + info object call y x +} -cleanup { + root destroy +} -result {{method x ::D method} {method x ::B method} {method x ::A method} {method x ::C method} {method x ::H method} {method x ::G method} {method x object method} {method x ::F method} {method x ::E method}} +test oo-call-1.21 {object call introspection - complex case} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method y {} {} + } + oo::class create ::C { + superclass root + method x {} {} + mixin B + } + oo::class create ::D { + superclass C + filter x + } + oo::class create ::E { + superclass root + method y {} {} + method x {} {} + } + oo::class create ::F { + superclass E + method z {} {} + method q {} {} + } + F create y + oo::objdefine y { + method unknown {} {} + mixin D + filter q + } + info object call y z +} -cleanup { + root destroy +} -result {{filter x ::C method} {filter x ::E method} {filter y ::B method} {filter y ::A method} {filter y ::E method} {filter q ::F method} {method z ::F method}} test oo-call-2.1 {class call introspection} -setup { oo::class create root -- cgit v0.12 From ae6dce9631c57669adb98a53fd8f2c36f9cdf7b0 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 29 Aug 2014 17:33:06 +0000 Subject: Use TclpSys* macros, not direct system calls. --- generic/tclThreadAlloc.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index ddf888a..5cb8027 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -287,7 +287,7 @@ TclFreeAllocCache( *nextPtrPtr = cachePtr->nextPtr; cachePtr->nextPtr = NULL; Tcl_MutexUnlock(listLockPtr); - free(cachePtr); + TclpSysFree(cachePtr); } /* @@ -332,7 +332,7 @@ TclpAlloc( /* * Increment the requested size to include room for the Block structure. - * Call malloc() directly if the required amount is greater than the + * Call TclpSysAlloc() directly if the required amount is greater than the * largest block, otherwise pop the smallest block large enough, * allocating more blocks if necessary. */ @@ -344,7 +344,7 @@ TclpAlloc( #endif if (size > MAXALLOC) { bucket = NBUCKETS; - blockPtr = malloc(size); + blockPtr = TclpSysAlloc(size, 0); if (blockPtr != NULL) { cachePtr->totalAssigned += reqSize; } @@ -407,7 +407,7 @@ TclpFree( bucket = blockPtr->sourceBucket; if (bucket == NBUCKETS) { cachePtr->totalAssigned -= blockPtr->blockReqSize; - free(blockPtr); + TclpSysFree(blockPtr); return; } @@ -472,7 +472,7 @@ TclpRealloc( /* * If the block is not a system block and fits in place, simply return the * existing pointer. Otherwise, if the block is a system block and the new - * size would also require a system block, call realloc() directly. + * size would also require a system block, call TclpSysRealloc() directly. */ blockPtr = Ptr2Block(ptr); @@ -495,7 +495,7 @@ TclpRealloc( } else if (size > MAXALLOC) { cachePtr->totalAssigned -= blockPtr->blockReqSize; cachePtr->totalAssigned += reqSize; - blockPtr = realloc(blockPtr, size); + blockPtr = TclpSysRealloc(blockPtr, size); if (blockPtr == NULL) { return NULL; } @@ -567,7 +567,7 @@ TclThreadAllocObj(void) Tcl_Obj *newObjsPtr; cachePtr->numObjects = numMove = NOBJALLOC; - newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); + newObjsPtr = TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %d new objects", numMove); } @@ -964,7 +964,7 @@ GetBlocks( if (blockPtr == NULL) { size = MAXALLOC; - blockPtr = malloc(size); + blockPtr = TclpSysAlloc(size, 0); if (blockPtr == NULL) { return 0; } -- cgit v0.12 From 3443754fe79d8eec50b4ad771335c2d17e75bda4 Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Tue, 2 Sep 2014 21:57:20 +0000 Subject: Add test cases in very first position for hang-on-exit, both in (normal) quick-exit and TCL_FINALIZE_ON_EXIT=1 modes. --- tests/aaa_exit.test | 41 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 tests/aaa_exit.test diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test new file mode 100644 index 0000000..51a94d7 --- /dev/null +++ b/tests/aaa_exit.test @@ -0,0 +1,41 @@ +# Commands covered: exit, emphasis on finalization hangs +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + + +test exit-1.1 {normal, quick exit} { + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\" 2>@ stderr" r] + set aft [after 5000 {set done "Quick exit hangs !!!"}] + fileevent $f readable {after cancel $aft;set done OK} + vwait done + catch {fconfigure $f -blocking 0;close $f} + set done +} OK + +test exit-1.2 {full-finalized exit} { + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\" 2>@ stderr" r] + set aft [after 5000 {set done "Full-finalized exit hangs !!!"}] + fileevent $f readable {after cancel $aft;set done OK} + vwait done + catch {fconfigure $f -blocking 0;close $f} + set done +} OK + + +# cleanup +::tcltest::cleanupTests +return -- cgit v0.12 From b5eef5811353c6b95840afa31bf070ddd7f8fc0b Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Tue, 2 Sep 2014 22:00:03 +0000 Subject: Refrain from calling TclFinalizeThreadData() in quick-exit case as it is useless (just memory freeing). Superficially fixes [Bug 132fad6f]; that bug is still exerciseable thanks to recent additions to the test suite that exercise full finalization. --- generic/tclEvent.c | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 941d566..ab219a6 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1299,18 +1299,20 @@ Tcl_FinalizeThread(void) TclFinalizeAsync(); TclFinalizeThreadObjects(); } + if (TclFullFinalizationRequested()) { /* useless if we are facing a quick-exit */ - /* - * Blow away all thread local storage blocks. - * - * Note that Tcl API allows creation of threads which do not use any Tcl - * interp or other Tcl subsytems. Those threads might, however, use thread - * local storage, so we must unconditionally finalize it. - * - * Fix [Bug #571002] - */ - - TclFinalizeThreadData(); + /* + * Blow away all thread local storage blocks. + * + * Note that Tcl API allows creation of threads which do not use any Tcl + * interp or other Tcl subsytems. Those threads might, however, use thread + * local storage, so we must unconditionally finalize it. + * + * Fix [Bug #571002] + */ + + TclFinalizeThreadData(); + } } /* -- cgit v0.12 From cb6bb091e91bf08ac9de9c6f71c175a273a1fe7d Mon Sep 17 00:00:00 2001 From: ashok Date: Wed, 3 Sep 2014 15:48:56 +0000 Subject: [132fad6fde]. Fixed GetCache to use TclpSysAlloc+memset instead of calloc. Now consistent with tclWinThrd.c which no longer uses malloc in its TclpSysAlloc implementation. --- generic/tclThreadAlloc.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 5cb8027..560556d 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -217,10 +217,11 @@ GetCache(void) cachePtr = TclpGetAllocCache(); if (cachePtr == NULL) { - cachePtr = calloc(1, sizeof(Cache)); + cachePtr = TclpSysAlloc(sizeof(Cache), 0); if (cachePtr == NULL) { Tcl_Panic("alloc: could not allocate new cache"); } + memset(cachePtr, 0, sizeof(Cache)); Tcl_MutexLock(listLockPtr); cachePtr->nextPtr = firstCachePtr; firstCachePtr = cachePtr; -- cgit v0.12 From 1a89b962c14bfe2afbbea3c1cca6266b3ed6b0bd Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Wed, 3 Sep 2014 19:44:29 +0000 Subject: Distinguish hanging from crashing in exit tests. --- tests/aaa_exit.test | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test index 51a94d7..3ba5167 100644 --- a/tests/aaa_exit.test +++ b/tests/aaa_exit.test @@ -16,22 +16,35 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } - test exit-1.1 {normal, quick exit} { - set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\" 2>@ stderr" r] - set aft [after 5000 {set done "Quick exit hangs !!!"}] + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r] + set aft [after 1000 {set done "Quick exit hangs !!!"}] fileevent $f readable {after cancel $aft;set done OK} vwait done - catch {fconfigure $f -blocking 0;close $f} + if {$done != "OK"} { + fconfigure $f -blocking 0 + close $f + } else { + if {[catch {close $f} err]} { + set done "Quick exit misbehaves: $err" + } + } set done } OK test exit-1.2 {full-finalized exit} { - set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\" 2>@ stderr" r] - set aft [after 5000 {set done "Full-finalized exit hangs !!!"}] + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\"" r] + set aft [after 1000 {set done "Full-finalized exit hangs !!!"}] fileevent $f readable {after cancel $aft;set done OK} vwait done - catch {fconfigure $f -blocking 0;close $f} + if {$done != "OK"} { + fconfigure $f -blocking 0 + close $f + } else { + if {[catch {close $f} err]} { + set done "Full-finalized exit misbehaves: $err" + } + } set done } OK -- cgit v0.12 From 7d79bddb583eaecee9586f384dae1af1470ce889 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Thu, 4 Sep 2014 22:05:21 +0000 Subject: Remove ChannelHandlerEvent struct, which has never been used in all of recorded Tcl history. Still need to purge comments of mentions of ChannelHandlerEventProc() which is similarly pre-historic. --- generic/tclIO.c | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index eaa0aeb..4bd90cc 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -58,17 +58,6 @@ typedef struct NextChannelHandler { } NextChannelHandler; /* - * The following structure describes the event that is added to the Tcl - * event queue by the channel handler check procedure. - */ - -typedef struct ChannelHandlerEvent { - Tcl_Event header; /* Standard header for all events. */ - Channel *chanPtr; /* The channel that is ready. */ - int readyMask; /* Events that have occurred. */ -} ChannelHandlerEvent; - -/* * The following structure is used by Tcl_GetsObj() to encapsulates the * state for a "gets" operation. */ -- cgit v0.12 From be8f61e9d764dc94706baf500f60173b42fdb27a Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Fri, 5 Sep 2014 10:05:05 +0000 Subject: [ccc2c2cc98]: lreplace edge case --- generic/tclCompCmdsGR.c | 14 +++++++++++++- tests/lreplace.test | 14 +++++++++++++- 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 166fea0..64dcaa6 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1480,7 +1480,7 @@ TclCompileLreplaceCmd( Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ Tcl_Obj *tmpObj; - int idx1, idx2, i, offset; + int idx1, idx2, i, offset, offset2; if (parsePtr->numWords < 4) { return TCL_ERROR; @@ -1586,12 +1586,18 @@ TclCompileLreplaceCmd( TclEmitOpcode( INST_GT, envPtr); offset = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + offset2 = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( "list doesn't contain element %d", idx1), NULL), envPtr); CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, + envPtr->codeStart + offset2 + 1); TclAdjustStackDepth(-1, envPtr); } TclEmitOpcode( INST_DUP, envPtr); @@ -1636,12 +1642,18 @@ TclCompileLreplaceCmd( TclEmitOpcode( INST_GT, envPtr); offset = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + offset2 = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( "list doesn't contain element %d", idx1), NULL), envPtr); CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, + envPtr->codeStart + offset2 + 1); TclAdjustStackDepth(-1, envPtr); } TclEmitOpcode( INST_DUP, envPtr); diff --git a/tests/lreplace.test b/tests/lreplace.test index 5f675bc..b976788 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -15,7 +15,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } - + test lreplace-1.1 {lreplace command} { lreplace {1 2 3 4 5} 0 0 a } {a 2 3 4 5} @@ -130,7 +130,19 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} { p } "a b c" +test lreplace-4.1 {Bug ccc2c2cc98: lreplace edge case} { + lreplace {} 1 1 +} {} +# Note that this test will fail in 8.5 +test lreplace-4.2 {Bug ccc2c2cc98: lreplace edge case} { + lreplace { } 1 1 +} {} + # cleanup catch {unset foo} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From efc3cc2032a492c511a53fcad5f3ea5174640f55 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 5 Sep 2014 18:30:57 +0000 Subject: Make corrections to long-false comments. --- generic/tclIO.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4bd90cc..dcde8d1 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -35,15 +35,15 @@ typedef struct ChannelHandler { /* * This structure keeps track of the current ChannelHandler being invoked in - * the current invocation of ChannelHandlerEventProc. There is a potential + * the current invocation of Tcl_NotifyChannel. There is a potential * problem if a ChannelHandler is deleted while it is the current one, since - * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * Tcl_NotifyChannel needs to look at the nextPtr field. To handle this * problem, structures of the type below indicate the next handler to be * processed for any (recursively nested) dispatches in progress. The * nextHandlerPtr field is updated if the handler being pointed to is deleted. - * The nextPtr field is used to chain together all recursive invocations, so - * that Tcl_DeleteChannelHandler can find all the recursively nested - * invocations of ChannelHandlerEventProc and compare the handler being + * The nestedHandlerPtr field is used to chain together all recursive + * invocations, so that Tcl_DeleteChannelHandler can find all the recursively + * nested invocations of Tcl_NotifyChannel and compare the handler being * deleted against the NEXT handler to be invoked in that invocation; when it * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr * field of the structure to the next handler. @@ -54,7 +54,7 @@ typedef struct NextChannelHandler { * this invocation. */ struct NextChannelHandler *nestedHandlerPtr; /* Next nested invocation of - * ChannelHandlerEventProc. */ + * Tcl_NotifyChannel. */ } NextChannelHandler; /* @@ -119,7 +119,7 @@ typedef struct CopyState { typedef struct ThreadSpecificData { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of nested - * ChannelHandlerEventProc invocations. */ + * Tcl_NotifyChannel invocations. */ ChannelState *firstCSPtr; /* List of all channels currently open, * indexed by ChannelState, as only one * ChannelState exists per set of stacked @@ -8089,7 +8089,7 @@ Tcl_NotifyChannel( /* * Add this invocation to the list of recursive invocations of - * ChannelHandlerEventProc. + * Tcl_NotifyChannel. */ nh.nextHandlerPtr = NULL; @@ -8408,7 +8408,7 @@ Tcl_DeleteChannelHandler( } /* - * If ChannelHandlerEventProc is about to process this handler, tell it to + * If Tcl_NotifyChannel is about to process this handler, tell it to * process the next one instead - we are going to delete *this* one. */ -- cgit v0.12 From 6ca59fdcc26dba64db9d911fbe7c3c79f991561d Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 5 Sep 2014 19:04:43 +0000 Subject: Remove unused macros. --- unix/tclUnixTime.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 926e8f4..4452022 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -16,9 +16,6 @@ #include #endif -#define TM_YEAR_BASE 1900 -#define IsLeapYear(x) (((x)%4 == 0) && ((x)%100 != 0 || (x)%400 == 0)) - /* * TclpGetDate is coded to return a pointer to a 'struct tm'. For thread * safety, this structure must be in thread-specific data. The 'tmKey' -- cgit v0.12 From 06a4f79ef6d98d4d17246a89fabc884f7240ce69 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Mon, 8 Sep 2014 21:22:05 +0000 Subject: Exceptional handling of oo::class has to be consistent throughout. --- generic/tclOO.c | 4 +++- tests/oo.test | 10 ++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index ace47fe..77e668b 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1287,7 +1287,9 @@ TclOORemoveFromInstances( removeInstance: if (Deleted(clsPtr->thisPtr)) { - DelRef(clsPtr->instances.list[i]); + if (!IsRootClass(clsPtr)) { + DelRef(clsPtr->instances.list[i]); + } clsPtr->instances.list[i] = NULL; } else { clsPtr->instances.num--; diff --git a/tests/oo.test b/tests/oo.test index 8c515da..2c189ca 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -271,6 +271,16 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup { } -cleanup { rename test-oo-1.18 {} } -result 0 +test oo-1.18.2 {Bug 21c144f0f5} -setup { + interp create slave +} -body { + slave eval { + oo::define [oo::class create foo] superclass oo::class + oo::class destroy + } +} -cleanup { + interp delete slave +} test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o namespace delete [info object namespace o] -- cgit v0.12 From 768bec87eb9e4a47b9d5d00a81f68cd68d663649 Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Mon, 8 Sep 2014 22:50:11 +0000 Subject: Refine TclFinalizeThreadData so that the quick-exit optimization really only affects exit. --- generic/tclEvent.c | 23 ++++++++++------------- generic/tclThread.c | 7 ++++++- 2 files changed, 16 insertions(+), 14 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index ab219a6..3985767 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1299,20 +1299,17 @@ Tcl_FinalizeThread(void) TclFinalizeAsync(); TclFinalizeThreadObjects(); } - if (TclFullFinalizationRequested()) { /* useless if we are facing a quick-exit */ - /* - * Blow away all thread local storage blocks. - * - * Note that Tcl API allows creation of threads which do not use any Tcl - * interp or other Tcl subsytems. Those threads might, however, use thread - * local storage, so we must unconditionally finalize it. - * - * Fix [Bug #571002] - */ - - TclFinalizeThreadData(); - } + /* + * Blow away all thread local storage blocks. + * + * Note that Tcl API allows creation of threads which do not use any Tcl + * interp or other Tcl subsytems. Those threads might, however, use thread + * local storage, so we must unconditionally finalize it. + * + * Fix [Bug #571002] + */ + TclFinalizeThreadData(); } /* diff --git a/generic/tclThread.c b/generic/tclThread.c index 8c972a8..5ac6a8d 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -357,7 +357,12 @@ TclFinalizeThreadData(void) { TclFinalizeThreadDataThread(); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclFinalizeThreadAllocThread(); + if ((!TclInExit())||TclFullFinalizationRequested()) { + /* + * Quick exit principle makes it useless to terminate allocators + */ + TclFinalizeThreadAllocThread(); + } #endif } -- cgit v0.12 From 771292c788a412c4ababbeecd13cf5d448e10169 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Tue, 9 Sep 2014 19:49:08 +0000 Subject: [84af1192f5]: [regsub] compiler no longer confused by quantification handling. --- generic/tclCompCmdsGR.c | 7 ++++--- generic/tclCompCmdsSZ.c | 2 +- generic/tclInt.h | 3 ++- generic/tclRegexp.c | 3 ++- generic/tclUtil.c | 9 ++++++++- tests/regexpComp.test | 5 +++++ 6 files changed, 22 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 64dcaa6..603c51d 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2270,7 +2270,7 @@ TclCompileRegexpCmd( * converted pattern as a literal. */ - if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) + if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL) == TCL_OK) { simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); @@ -2362,7 +2362,7 @@ TclCompileRegsubCmd( Tcl_Obj *patternObj = NULL, *replacementObj = NULL; Tcl_DString pattern; const char *bytes; - int len, exact, result = TCL_ERROR; + int len, exact, quantified, result = TCL_ERROR; if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { return TCL_ERROR; @@ -2422,7 +2422,8 @@ TclCompileRegsubCmd( */ bytes = Tcl_GetStringFromObj(patternObj, &len); - if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { + if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) + != TCL_OK || exact || quantified) { goto done; } bytes = Tcl_DStringValue(&pattern); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index f2e5dd2..28cab1e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2091,7 +2091,7 @@ IssueSwitchChainedTests( */ if (TclReToGlob(NULL, bodyToken[i]->start, - bodyToken[i]->size, &ds, &exact) == TCL_OK) { + bodyToken[i]->size, &ds, &exact, NULL) == TCL_OK){ simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); diff --git a/generic/tclInt.h b/generic/tclInt.h index 6bf1ef9..7287a13 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3095,7 +3095,8 @@ MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, - int reStrLen, Tcl_DString *dsPtr, int *flagsPtr); + int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, + int *quantifiersFoundPtr); MODULE_SCOPE int TclScanElement(const char *string, int length, int *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 6348e4a..5bc3aa2 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -946,7 +946,8 @@ CompileRegexp( * Tcl_RegExpExecObj to optionally do a fast match (avoids RE engine). */ - if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) { + if (TclReToGlob(NULL, string, length, &stringBuf, &exact, + NULL) == TCL_OK) { regexpPtr->globObjPtr = TclDStringToObj(&stringBuf); Tcl_IncrRefCount(regexpPtr->globObjPtr); } else { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index ae3adae..64589a2 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4249,7 +4249,8 @@ TclReToGlob( const char *reStr, int reStrLen, Tcl_DString *dsPtr, - int *exactPtr) + int *exactPtr, + int *quantifiersFoundPtr) { int anchorLeft, anchorRight, lastIsStar, numStars; char *dsStr, *dsStrStart; @@ -4257,6 +4258,9 @@ TclReToGlob( strEnd = reStr + reStrLen; Tcl_DStringInit(dsPtr); + if (quantifiersFoundPtr != NULL) { + *quantifiersFoundPtr = 0; + } /* * "***=xxx" == "*xxx*", watch for glob-sensitive chars. @@ -4369,6 +4373,9 @@ TclReToGlob( } break; case '.': + if (quantifiersFoundPtr != NULL) { + *quantifiersFoundPtr = 1; + } anchorLeft = 0; /* prevent exact match */ if (p+1 < strEnd) { if (p[1] == '*') { diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 7be1195..01ef06d 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -526,6 +526,11 @@ test regexpComp-9.6 {-all option to regsub} { list [regsub -all ^ xxx 123 foo] $foo } } {1 123xxx} +test regexpComp-9.7 {Bug 84af1192f5: -all option to regsub} { + evalInProc { + regsub -all {\(.*} 123(qwe) "" + } +} 123 test regexpComp-10.1 {expanded syntax in regsub} { evalInProc { -- cgit v0.12 From 965ab2357ea576564bb89758eca48ba60e7e8046 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Wed, 10 Sep 2014 22:17:21 +0000 Subject: [cee90e4e88] Correct error in stack depth checking. --- generic/tclCompCmdsSZ.c | 1 + tests/error.test | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 28cab1e..ed9c088 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -3038,6 +3038,7 @@ IssueTryClausesInstructions( if (!handlerTokens[i]) { forwardsNeedFixing = 1; JUMP4( JUMP, forwardsToFix[i]); + TclAdjustStackDepth(1, envPtr); } else { int dontChangeOptions; diff --git a/tests/error.test b/tests/error.test index 0de644c..af07ed7 100644 --- a/tests/error.test +++ b/tests/error.test @@ -1184,6 +1184,12 @@ test error-21.8 {memory leaks in try: Bug 2910044} memory { } } 0 +test error-21.9 {Bug cee90e4e88} { + # Just don't panic. + apply {{} {try {} on ok {} - on return {} {}}} +} {} + + # negative case try tests - bad "trap" handler # what is the effect if we attempt to trap an errorcode that is not a list? # nested try -- cgit v0.12 From 5621e1f449a77cb681a20208fcd3f7815fc11b3c Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Sun, 14 Sep 2014 17:11:33 +0000 Subject: whitespace tweak --- generic/tclDisassemble.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 00b5549..9556d46 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1107,10 +1107,12 @@ DisassembleByteCodeAsDicts( Tcl_NewIntObj(codeOffset)); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1), Tcl_NewIntObj(codeOffset + codeLength - 1)); + /* * Convert byte offsets to character offsets; important if multibyte * characters are present in the source! */ + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, sourceOffset))); -- cgit v0.12 From 1eb412e30230841dda1d9725af0d5e8f13bfd13b Mon Sep 17 00:00:00 2001 From: "stwo@users.sourceforge.net" Date: Tue, 16 Sep 2014 15:48:48 +0000 Subject: Better pic flag for OpenBSD. --- unix/configure | 9 ++++++++- unix/tcl.m4 | 9 ++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index a82c692..5291bf7 100755 --- a/unix/configure +++ b/unix/configure @@ -7676,7 +7676,14 @@ fi LDFLAGS="" ;; *) - SHLIB_CFLAGS="-fPIC" + case "$arch" in + alpha|sparc64) + SHLIB_CFLAGS="-fPIC" + ;; + *) + SHLIB_CFLAGS="-fpic" + ;; + esac SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 3ca65d8..277fe0b 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1475,7 +1475,14 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LDFLAGS="" ;; *) - SHLIB_CFLAGS="-fPIC" + case "$arch" in + alpha|sparc64) + SHLIB_CFLAGS="-fPIC" + ;; + *) + SHLIB_CFLAGS="-fpic" + ;; + esac SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" -- cgit v0.12 From c14aa0872c4a6938aedbb420efeca83e73baaf9f Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Sat, 20 Sep 2014 11:40:35 +0000 Subject: Tidy things up a bit more. --- generic/tclDisassemble.c | 17 +++++++++++++---- generic/tclProc.c | 2 +- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 9556d46..b3753c31 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -21,6 +21,7 @@ * Prototypes for procedures defined later in this file: */ +static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void PrintSourceToObj(Tcl_Obj *appendObj, @@ -39,6 +40,13 @@ static const Tcl_ObjType tclInstNameType = { UpdateStringOfInstName, /* updateStringProc */ NULL, /* setFromAnyProc */ }; + +/* + * How to get the bytecode out of a Tcl_Obj. + */ + +#define BYTECODE(objPtr) \ + ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1) #ifdef TCL_COMPILE_DEBUG /* @@ -181,7 +189,7 @@ Tcl_Obj * TclDisassembleByteCodeObj( Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr = BYTECODE(objPtr); unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; @@ -858,7 +866,7 @@ static Tcl_Obj * DisassembleByteCodeAsDicts( Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ { - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr = BYTECODE(objPtr); Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; @@ -1201,6 +1209,8 @@ Tcl_DisassembleObjCmd( /* * Compile (if uncompiled) and disassemble a lambda term. + * + * WARNING! Pokes inside the lambda objtype. */ if (objc != 3) { @@ -1368,8 +1378,7 @@ Tcl_DisassembleObjCmd( * Do the actual disassembly. */ - if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags - & TCL_BYTECODE_PRECOMPILED) { + if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", diff --git a/generic/tclProc.c b/generic/tclProc.c index 42c9a72..e0d6ec7 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -88,7 +88,7 @@ static const Tcl_ObjType levelReferenceType = { * * Internally, ptr1 is a pointer to a Proc instance that is not bound to a * command name, and ptr2 is a pointer to the namespace that the Proc instance - * will execute within. + * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. */ const Tcl_ObjType tclLambdaType = { -- cgit v0.12 From 2d826a696acf94c7c54e9649ea0a7ff1859b2f08 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Thu, 25 Sep 2014 18:47:32 +0000 Subject: comment fix --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 7287a13..860c2a3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1741,7 +1741,7 @@ enum PkgPreferOptions { * definition there. * Some macros require knowledge of some fields in the struct in order to * avoid hitting the TSD unnecessarily. In order to facilitate this, a pointer - * to the relevant fields is kept in the objCache field in struct Interp. + * to the relevant fields is kept in the allocCache field in struct Interp. *---------------------------------------------------------------- */ -- cgit v0.12 From 4a202f4e68eb7a229138f90a42e5731c89b82c06 Mon Sep 17 00:00:00 2001 From: "harald.oehlmann@elmicron.de" Date: Fri, 26 Sep 2014 12:05:30 +0000 Subject: Implemented tip-427: socket fconfigure option -connecting plus no -peername,-sockname when still connecting. --- unix/tclUnixSock.c | 34 +++++++++++++++---- win/tclWinSock.c | 97 ++++++++++++++++++++++++++++++++---------------------- 2 files changed, 85 insertions(+), 46 deletions(-) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 96700ce..ca25435 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -823,7 +823,20 @@ TcpGetOptionProc( address peername; socklen_t size = sizeof(peername); - if (getpeername(statePtr->fds.fd, &peername.sa, &size) >= 0) { + if ( (statePtr->flags & TCP_ASYNC_CONNECT) ) { + /* + * In async connect output an empty string + */ + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringAppendElement(dsPtr, ""); + } else { + return TCL_OK; + } + } else if (getpeername(statePtr->fds.fd, &peername.sa, &size) >= 0) { + /* + * Peername fetch succeeded - output list + */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); @@ -863,11 +876,18 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); } - for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { - size = sizeof(sockname); - if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) { - found = 1; - TcpHostPortList(interp, dsPtr, sockname, size); + if ( (statePtr->flags & TCP_ASYNC_CONNECT) ) { + /* + * In async connect output an empty string + */ + found = 1; + } else { + for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { + size = sizeof(sockname); + if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) { + found = 1; + TcpHostPortList(interp, dsPtr, sockname, size); + } } } if (found) { @@ -885,7 +905,7 @@ TcpGetOptionProc( } if (len > 0) { - return Tcl_BadChannelOption(interp, optionName, "peername sockname"); + return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname"); } return TCL_OK; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index f343f82..900f7c4 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1337,7 +1337,20 @@ TcpGetOptionProc( address peername; socklen_t size = sizeof(peername); - if (getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { + if ( (statePtr->flags & TCP_ASYNC_PENDING) ) { + /* + * In async connect output an empty string + */ + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringAppendElement(dsPtr, ""); + } else { + return TCL_OK; + } + } else if ( getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { + /* + * Peername fetch succeeded - output list + */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); @@ -1386,49 +1399,55 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); } - for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { - sock = fds->fd; - size = sizeof(sockname); - if (getsockname(sock, &(sockname.sa), &size) >= 0) { - int flags = reverseDNS; - - found = 1; - getnameinfo(&sockname.sa, size, host, sizeof(host), - NULL, 0, NI_NUMERICHOST); - Tcl_DStringAppendElement(dsPtr, host); - - /* - * We don't want to resolve INADDR_ANY and sin6addr_any; they - * can sometimes cause problems (and never have a name). - */ - flags |= NI_NUMERICSERV; - if (sockname.sa.sa_family == AF_INET) { - if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { - flags |= NI_NUMERICHOST; - } - } else if (sockname.sa.sa_family == AF_INET6) { - if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr, - &in6addr_any)) || - (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) - && sockname.sa6.sin6_addr.s6_addr[12] == 0 - && sockname.sa6.sin6_addr.s6_addr[13] == 0 - && sockname.sa6.sin6_addr.s6_addr[14] == 0 - && sockname.sa6.sin6_addr.s6_addr[15] == 0)) { - flags |= NI_NUMERICHOST; + if ( (statePtr->flags & TCP_ASYNC_PENDING ) ) { + /* + * In async connect output an empty string + */ + found = 1; + } else { + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + sock = fds->fd; + size = sizeof(sockname); + if (getsockname(sock, &(sockname.sa), &size) >= 0) { + int flags = reverseDNS; + + found = 1; + getnameinfo(&sockname.sa, size, host, sizeof(host), + NULL, 0, NI_NUMERICHOST); + Tcl_DStringAppendElement(dsPtr, host); + + /* + * We don't want to resolve INADDR_ANY and sin6addr_any; they + * can sometimes cause problems (and never have a name). + */ + flags |= NI_NUMERICSERV; + if (sockname.sa.sa_family == AF_INET) { + if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { + flags |= NI_NUMERICHOST; + } + } else if (sockname.sa.sa_family == AF_INET6) { + if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr, + &in6addr_any)) || + (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) + && sockname.sa6.sin6_addr.s6_addr[12] == 0 + && sockname.sa6.sin6_addr.s6_addr[13] == 0 + && sockname.sa6.sin6_addr.s6_addr[14] == 0 + && sockname.sa6.sin6_addr.s6_addr[15] == 0)) { + flags |= NI_NUMERICHOST; + } } + getnameinfo(&sockname.sa, size, host, sizeof(host), + port, sizeof(port), flags); + Tcl_DStringAppendElement(dsPtr, host); + Tcl_DStringAppendElement(dsPtr, port); } - getnameinfo(&sockname.sa, size, host, sizeof(host), - port, sizeof(port), flags); - Tcl_DStringAppendElement(dsPtr, host); - Tcl_DStringAppendElement(dsPtr, port); } } if (found) { - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { + if (len) { return TCL_OK; } + Tcl_DStringEndSublist(dsPtr); } else { if (interp) { TclWinConvertError((DWORD) WSAGetLastError()); @@ -1482,9 +1501,9 @@ TcpGetOptionProc( if (len > 0) { #ifdef TCL_FEATURE_KEEPALIVE_NAGLE return Tcl_BadChannelOption(interp, optionName, - "peername sockname keepalive nagle"); + "connecting peername sockname keepalive nagle"); #else - return Tcl_BadChannelOption(interp, optionName, "peername sockname"); + return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname"); #endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } -- cgit v0.12 From 5f55e639be0620a51dc2496ee42f9bf6dc5f55f7 Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Sat, 27 Sep 2014 20:28:47 +0000 Subject: Applied patch by Andreas Leitgeb so that [string cat]'s compiled bytecode optimally groups args by 255 for INSTR_STR_CONCAT1. --- generic/tclCompCmdsSZ.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 2b83fd2..617a520 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -322,8 +322,8 @@ TclCompileStringCatCmd( CompileWord(envPtr, wordTokenPtr, interp, i); numArgs ++; if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */ - TclEmitInstInt1(INST_STR_CONCAT1, 254, envPtr); - numArgs -= 253; /* concat pushes 1 obj, the result */ + TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); + numArgs = 1; /* concat pushes 1 obj, the result */ } } wordTokenPtr = TokenAfter(wordTokenPtr); -- cgit v0.12 From 6c22c553d43156db2e98a5d1904c9001283bb2e7 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Sat, 27 Sep 2014 21:36:06 +0000 Subject: Backing out commit [cddbfc3081], fix for bug [82521bfb6734f891dd] The "optimisation" in that commit assumes that the last byte in the generated bytecodes is an INST_TRY_CONVERT if it equals 64. This is an invalid assumption, it could be 64 and not be an instruction. --- generic/tclCompCmds.c | 1 - generic/tclCompCmdsGR.c | 2 -- generic/tclCompCmdsSZ.c | 1 - generic/tclCompile.h | 12 ------------ 4 files changed, 16 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 431f0af..496d44f 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2401,7 +2401,6 @@ TclCompileForCmd( SetLineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - TclClearNumConversion(envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 603c51d..9d258fc 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -281,7 +281,6 @@ TclCompileIfCmd( SetLineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - TclClearNumConversion(envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } @@ -531,7 +530,6 @@ TclCompileIncrCmd( } else { SetLineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); - TclClearNumConversion(envPtr); } } else { /* No incr amount given so use 1. */ haveImmValue = 1; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 617a520..382d2d1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -3782,7 +3782,6 @@ TclCompileWhileCmd( } SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - TclClearNumConversion(envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 01b78d9..51f0b34 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1414,18 +1414,6 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, } while (0) /* - * If the expr compiler finished with TRY_CONVERT, macro to remove it when the - * job is done by the following instruction. - */ - -#define TclClearNumConversion(envPtr) \ - do { \ - if (*(envPtr->codeNext - 1) == INST_TRY_CVT_TO_NUMERIC) { \ - envPtr->codeNext--; \ - } \ - } while (0) - -/* * Macros to update a (signed or unsigned) integer starting at a pointer. The * two variants depend on the number of bytes. The ANSI C "prototypes" for * these macros are: -- cgit v0.12 From ffcb80ed9649f929513f7313f8e99841bd1feeef Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Thu, 2 Oct 2014 17:43:16 +0000 Subject: [bc1a96407a] Partial solution should avoid crash, but may lead to wrong behavior. --- generic/tclTrace.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/generic/tclTrace.c b/generic/tclTrace.c index c0cde49..2a348e6 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -2511,7 +2511,11 @@ TclObjCallVarTraces( if (!part1Ptr) { part1Ptr = localName(iPtr->varFramePtr, index); } - part1 = TclGetString(part1Ptr); + if (part1Ptr) { + part1 = TclGetString(part1Ptr); + } else { + part1 = tclEmptyString; + } part2 = part2Ptr? TclGetString(part2Ptr) : NULL; return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, -- cgit v0.12 From 1f05d6a3e9702cce698db2abb5d12c2e710b7de8 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Thu, 2 Oct 2014 21:40:13 +0000 Subject: Possible fix for testing. --- generic/tclCompCmds.c | 8 +++++--- generic/tclTrace.c | 7 +++---- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 496d44f..18f4564 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -301,7 +301,8 @@ TclCompileArraySetCmd( * a proc, we cannot do a better compile than generic. */ - if (envPtr->procPtr == NULL && !(isDataEven && len == 0)) { + if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || + (envPtr->procPtr == NULL && !(isDataEven && len == 0))) { code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); goto done; } @@ -342,8 +343,9 @@ TclCompileArraySetCmd( * a non-local variable: upvar from a local one! This consumes the * variable name that was left at stacktop. */ - - localIndex = AnonymousLocal(envPtr); + + localIndex = TclFindCompiledLocal(varTokenPtr->start, + varTokenPtr->size, 1, envPtr); PushStringLiteral(envPtr, "0"); TclEmitInstInt4(INST_REVERSE, 2, envPtr); TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 2a348e6..6184a89 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -2511,11 +2511,10 @@ TclObjCallVarTraces( if (!part1Ptr) { part1Ptr = localName(iPtr->varFramePtr, index); } - if (part1Ptr) { - part1 = TclGetString(part1Ptr); - } else { - part1 = tclEmptyString; + if (!part1Ptr) { + Tcl_Panic("Cannot trace a variable with no name"); } + part1 = TclGetString(part1Ptr); part2 = part2Ptr? TclGetString(part2Ptr) : NULL; return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, -- cgit v0.12 From 27430258dc37a09bc3f179097bbdd12ed0e8ab4a Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 3 Oct 2014 15:47:38 +0000 Subject: test cases --- tests/var.test | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/var.test b/tests/var.test index 8e862f7..a7950be 100644 --- a/tests/var.test +++ b/tests/var.test @@ -865,6 +865,17 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup { }} array size x } -result 0 +test var-20.9 {[bc1a96407a] array set compiled w/ trace} { + variable foo + lappend lambda {} + lappend lambda [list array set [namespace which -variable foo] {a 1}] + after 0 [list apply $lambda] + vwait [namespace which -variable foo] + unset -nocomplain lambda foo +} {} +test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body { + apply {{} {set name foo(bar); array set $name {a 1}}} +} -returnCodes error -match glob -result * test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { proc linenumber {} {dict get [info frame -1] line} -- cgit v0.12 From 85b49f8b9ff228ad7e04eba511d0ce180f460308 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 10 Oct 2014 19:02:37 +0000 Subject: Another test so both DoRead and MBRead are covered. --- tests/io.test | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/tests/io.test b/tests/io.test index b657999..d9a5167 100644 --- a/tests/io.test +++ b/tests/io.test @@ -7752,6 +7752,50 @@ test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { close $c removeFile out } -result 100 +test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup { + proc driver {cmd args} { + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 -translation lf + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 -translation lf +} -body { + chan copy $c $outChan +} -cleanup { + close $outChan + close $c + removeFile out +} -result 100 test io-54.1 {Recursive channel events} {socket fileevent} { # This test checks to see if file events are delivered during recursive -- cgit v0.12 From 48c2b0c4fcf0e14eaf8b572f914002e300c672ed Mon Sep 17 00:00:00 2001 From: "ferrieux@users.sourceforge.net" Date: Fri, 10 Oct 2014 19:36:17 +0000 Subject: Add Colin's test for coro floor above street level [Bug #3008307] --- tests/coroutine.test | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index 05b58c9..205da67 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -726,6 +726,20 @@ test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup { catch {namespace delete ::cotest} catch {rename cotest ""} } -result {yieldto called in deleted namespace} +test coroutine-7.12 {coro floor above street level #3008307} -body { + proc c {} { + yield + } + proc cc {} { + coroutine C c + } + proc boom {} { + cc ; # coro created at level 2 + C ; # and called at level 1 + } + boom ; # does not crash: the coro floor is a good insulator + list +} -result {} # cleanup -- cgit v0.12 From 97a9d0dc4f29302f2359e1fa6afbb6bd16041913 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 10 Oct 2014 19:44:54 +0000 Subject: [ed29c4da21] Completed fix for [chan copy] handling [chan blocked]. --- generic/tclIO.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 3d36d45..2810372 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9020,7 +9020,7 @@ MBRead( } code = GetInput(inStatePtr->topChanPtr); - if (code == 0) { + if (code == 0 || GotFlag(inStatePtr, CHANNEL_BLOCKED)) { return TCL_OK; } else { MBError(csPtr, TCL_READABLE, code); @@ -9270,6 +9270,10 @@ CopyData( csPtr); } if (size == 0) { + if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) { + /* We allowed a short read. Keep trying. */ + continue; + } if (bufObj != NULL) { TclDecrRefCount(bufObj); bufObj = NULL; -- cgit v0.12 From 4556b0c45bbc8ded0ca02e44ee2f5dc8f7a68157 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 10 Oct 2014 20:37:58 +0000 Subject: Resolve test conflicts over global vars --- tests/utf.test | 6 ++++-- tests/var.test | 9 +++++++-- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/tests/utf.test b/tests/utf.test index 2fcac49..83daddf 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -287,9 +287,11 @@ test utf-18.5 {Tcl_UniCharToTitle, no delta} { string totitle ! } ! -test utf-19.1 {TclUniCharLen} { +test utf-19.1 {TclUniCharLen} -body { list [regexp \\d abc456def foo] $foo -} {1 4} +} -cleanup { + unset -nocomplain foo +} -result {1 4} test utf-20.1 {TclUniCharNcmp} { } {} diff --git a/tests/var.test b/tests/var.test index a7950be..7ff394e 100644 --- a/tests/var.test +++ b/tests/var.test @@ -865,14 +865,19 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup { }} array size x } -result 0 -test var-20.9 {[bc1a96407a] array set compiled w/ trace} { +test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup { variable foo + variable lambda + unset -nocomplain lambda foo + array set foo {} lappend lambda {} lappend lambda [list array set [namespace which -variable foo] {a 1}] +} -body { after 0 [list apply $lambda] vwait [namespace which -variable foo] +} -cleanup { unset -nocomplain lambda foo -} {} +} -result {} test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body { apply {{} {set name foo(bar); array set $name {a 1}}} } -returnCodes error -match glob -result * -- cgit v0.12 From 45fb7c9f020f4c2ae40153f7be0991626775a582 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Tue, 14 Oct 2014 18:12:36 +0000 Subject: Bump to Tcl 8.6.3, TclOO 1.0.3, and update changes file. --- README | 2 +- changes | 29 +++++++++++++++++++++++++++++ generic/tcl.h | 4 ++-- generic/tclOO.h | 2 +- library/init.tcl | 2 +- tests/oo.test | 2 +- tests/ooNext2.test | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- unix/tclooConfig.sh | 2 +- win/configure | 2 +- win/configure.in | 2 +- win/tclooConfig.sh | 2 +- 14 files changed, 43 insertions(+), 14 deletions(-) diff --git a/README b/README index 66e1b76..0fb128d 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6.2 source distribution. + This is the Tcl 8.6.3 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/changes b/changes index ba0854b..02b6ddc 100644 --- a/changes +++ b/changes @@ -8452,3 +8452,32 @@ include ::oo::class (fellows) 2014-08-25 (TIP 429) New command [string cat] (leitgeb,ferrieux) --- Released 8.6.2, August 27, 2014 --- http://core.tcl.tk/tcl/ for details + +2014-08-28 (bug)[b9e1a3] Correct Method Search Order (nadkarni,fellows) +=> TclOO 1.0.3 + +2014-09-05 (bug)[ccc2c2] Regression [lreplace {} 1 1] (bron,fellows) + +2014-09-08 (bug) Crash regression in [oo::class destroy] (porter) + +2014-09-09 (bug)[84af11] Regress [regsub -all {\(.*} a(b) {}] (oehlmann,fellows) + +2014-09-10 (bug)[cee90e] [try {} on ok {} - on return {} {}] panic (porter) + +2014-09-20 (feature) [tcl::unsupported::getbytecode] disassember (fellows) + +2014-09-27 (enhancement) [string cat] bytecode optimization (leitgeb,ferrieux) + +2014-09-27 (bug)[82521b] segfault in mangled bytecode (ogilvie,sofer) + +2014-10-02 (bug)[bc5b79] Hang in some [read]s of limited size (rogers,porter) + +2014-10-03 (bug)[bc1a96] segfault in [array set] of traced array (tab,porter) + +2014-10-08 (bug)[59a2e7] MSVC14 compile support (dower,nijtmans) + +2014-10-10 (bug)[ed29c4] [fcopy] treats [blocked] as error (rowen,porter) + +2014-10-10 (bug)[bf7135] regression in Tcl_Write() interface (porter) + +--- Released 8.6.3, October 29, 2014 --- http://core.tcl.tk/tcl/ for details diff --git a/generic/tcl.h b/generic/tcl.h index 7531242..fc477f2 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 3 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.2" +#define TCL_PATCH_LEVEL "8.6.3" /* *---------------------------------------------------------------------------- diff --git a/generic/tclOO.h b/generic/tclOO.h index 24d3e6f..a7116dc 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,7 +24,7 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0.2" +#define TCLOO_VERSION "1.0.3" #define TCLOO_PATCHLEVEL TCLOO_VERSION #include "tcl.h" diff --git a/library/init.tcl b/library/init.tcl index 265f928..f1f7704 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6.2 +package require -exact Tcl 8.6.3 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/tests/oo.test b/tests/oo.test index 2c189ca..5fa760b 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.1 +package require TclOO 1.0.3 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 9a63577..5ecd209 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.1 +package require TclOO 1.0.3 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/unix/configure b/unix/configure index 5291bf7..a9837d9 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".2" +TCL_PATCH_LEVEL=".3" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/configure.in b/unix/configure.in index 85bd7ee..e44d554 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".2" +TCL_PATCH_LEVEL=".3" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index 50aacc6..d660f74 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6.2 +Version: 8.6.3 Release: 2 License: BSD Group: Development/Languages diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 14b0d8d..55fe75f 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0.2 +TCLOO_VERSION=1.0.3 diff --git a/win/configure b/win/configure index cf2b201..b270648 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".2" +TCL_PATCH_LEVEL=".3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index aa47505..1bf901a 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".2" +TCL_PATCH_LEVEL=".3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 14b0d8d..55fe75f 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0.2 +TCLOO_VERSION=1.0.3 -- cgit v0.12 From ccae7f87b4ac290d65ee01edb60e11c32abe3a54 Mon Sep 17 00:00:00 2001 From: "harald.oehlmann@elmicron.de" Date: Fri, 17 Oct 2014 12:28:55 +0000 Subject: New tests: 14.16: -peername empty while async connect running, 14.17: -sockname --- tests/socket.test | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/tests/socket.test b/tests/socket.test index c50730c..d6cee30 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -2321,6 +2321,28 @@ test socket-14.15 {blocking read on async socket should not trigger event handle set x } -result ok +# v4 and v6 is required to prevent that the async connect does not terminate +# before the fconfigure command. There is always an additional ip to try. +test socket-14.16 {empty -peername while [socket -async] connecting} \ + -constraints {socket localhost_v4 localhost_v6} \ + -body { + set client [socket -async localhost [randport]] + fconfigure $client -peername + } -cleanup { + catch {close $client} + } -result {} + +# v4 and v6 is required to prevent that the async connect does not terminate +# before the fconfigure command. There is always an additional ip to try. +test socket-14.17 {empty -sockname while [socket -async] connecting} \ + -constraints {socket localhost_v4 localhost_v6} \ + -body { + set client [socket -async localhost [randport]] + fconfigure $client -sockname + } -cleanup { + catch {close $client} + } -result {} + set num 0 set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}} -- cgit v0.12 From 87b595c82c1511ed45d9c87de33083ef9742be88 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Wed, 22 Oct 2014 14:46:33 +0000 Subject: by request --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index 3e6e53b..03184e4 100644 --- a/changes +++ b/changes @@ -8460,7 +8460,7 @@ include ::oo::class (fellows) 2014-09-08 (bug) Crash regression in [oo::class destroy] (porter) -2014-09-09 (bug)[84af11] Regress [regsub -all {\(.*} a(b) {}] (oehlmann,fellows) +2014-09-09 (bug)[84af11] Regress [regsub -all {\(.*} a(b) {}] (fellows) 2014-09-10 (bug)[cee90e] [try {} on ok {} - on return {} {}] panic (porter) -- cgit v0.12 From daef2bf1e73d5de9488cef0eb07320b88d682714 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Sat, 1 Nov 2014 14:52:55 +0000 Subject: Disable assertion until tls bug it detects is fixed. --- generic/tclIO.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 207ce19..9cbc72c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -2811,9 +2811,15 @@ FlushChannel( * write in this call, and we've completed the BG flush. * These are the two cases above. If we get here, that means * there is some kind failure in the writable event machinery. - */ + * + * The tls extension indeed suffers from flaws in its channel + * event mgmt. See http://core.tcl.tk/tcl/info/c31ca233ca. + * Until that patch is broadly distributed, disable the + * assertion checking here, so that programs using Tcl and + * tls can be debugged. assert(!calledFromAsyncFlush); + */ } } -- cgit v0.12 From 0bea270685e3d32f087a303d29587c57b6fa8cdf Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Mon, 3 Nov 2014 21:37:37 +0000 Subject: Make sure reflected channels do not make a double call to Tcl_ReadRaw(), with the unwarranted assumption that EOF is a permanent condition. --- generic/tclIORTrans.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 45ee08d..8f3ef3c 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -1097,6 +1097,11 @@ ReflectInput( goto stop; } + if (rtPtr->readIsDrained) { + goto stop; + } + + /* * The buffer is exhausted, but the caller wants even more. We now * have to go to the underlying channel, get more bytes and then @@ -1166,10 +1171,6 @@ ReflectInput( * on the down channel. */ - if (rtPtr->readIsDrained) { - goto stop; - } - /* * Now this is a bit different. The partial data waiting is * converted and returned. -- cgit v0.12 From 5066c745ae84ee76062ab699badd546fadaf7b78 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Wed, 5 Nov 2014 06:36:07 +0000 Subject: [214cc0eb22] Restore [lappend $var] return value to the 8.6.1- behavior. If this is going to change, lets not do it by accident. --- generic/tclCompCmdsGR.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 9d258fc..98407f7 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -871,7 +871,7 @@ TclCompileLappendCmd( /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; - if (numWords == 1) { + if (numWords < 3) { return TCL_ERROR; } -- cgit v0.12 From 3414bceea185a4183444fb6ac6571eca5f577f63 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Wed, 5 Nov 2014 16:47:00 +0000 Subject: New test iortrans-4.10 to demo failure of channel transformation to handle fleeting EOF in the base channel. Falls into infinite block. Regression compared with Tcl 8.6.1. --- tests/ioTrans.test | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 53078f7..f1fa733 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -597,6 +597,62 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup { rename foo {} } -result {{read rt* {test data }} {}} +test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ..... + return {initialize finalize watch read} + } + finalize { + if {![info exists index($chan)]} {return} + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {![info exists index($chan)]} { + driver initialize $chan + } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + if {[string length $result] == 0} { + driver finalize $chan + } + return $result + } + } + } + proc idxform {cmd handle args} { + switch -- $cmd { + initialize { + return {initialize finalize read} + } + finalize { + return + } + read { + lassign $args buffer + return $buffer + } + } + } +} -body { + set chan [chan push [chan create read driver] idxform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan + rename idxform {} + rename driver {} +} -result {0 ..... 1 {} 0 ..... 1} + # --- === *** ########################### # method write (via puts) -- cgit v0.12 From 21e64f9873d92a798edf517c09d9e299aa342672 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Wed, 5 Nov 2014 20:34:03 +0000 Subject: Reflected Transform channel fix. Be sure each EOF on the base channel gets passed up to become an eof of the transform before continuing on to additional ReadRaw() from the base channel. This way we don't miss fleeting EOFs. --- generic/tclIORTrans.c | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 8f3ef3c..8baa9ad 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -161,6 +161,7 @@ typedef struct { int mode; /* Mask of R/W mode */ int nonblocking; /* Flag: Channel is blocking or not. */ int readIsDrained; /* Flag: Read buffers are flushed. */ + int eofPending; /* Flag: EOF seen down, but not raised up */ int dead; /* Boolean signal that some operations * should no longer be attempted. */ ResultBuffer result; @@ -1082,6 +1083,10 @@ ReflectInput( bufObj = Tcl_NewByteArrayObj(NULL, toRead); Tcl_IncrRefCount(bufObj); gotBytes = 0; + if (rtPtr->eofPending) { + goto stop; + } + rtPtr->readIsDrained = 0; while (toRead > 0) { /* * Loop until the request is satisfied (or no data available from @@ -1097,9 +1102,9 @@ ReflectInput( goto stop; } - if (rtPtr->readIsDrained) { - goto stop; - } + if (rtPtr->eofPending) { + goto stop; + } /* @@ -1170,6 +1175,8 @@ ReflectInput( * Zero returned from Tcl_ReadRaw() always indicates EOF * on the down channel. */ + + rtPtr->eofPending = 1; /* * Now this is a bit different. The partial data waiting is @@ -1212,6 +1219,9 @@ ReflectInput( } /* while toRead > 0 */ stop: + if (gotBytes == 0) { + rtPtr->eofPending = 0; + } Tcl_DecrRefCount(bufObj); Tcl_Release(rtPtr); return gotBytes; @@ -1767,6 +1777,7 @@ NewReflectedTransform( rtPtr->timer = NULL; rtPtr->mode = 0; rtPtr->readIsDrained = 0; + rtPtr->eofPending = 0; rtPtr->nonblocking = (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING); rtPtr->dead = 0; @@ -3319,6 +3330,7 @@ TransformClear( (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL); rtPtr->readIsDrained = 0; + rtPtr->eofPending = 0; ResultClear(&rtPtr->result); } -- cgit v0.12 From af47b47cda619a387c230e94164df7d323d3b35e Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Thu, 6 Nov 2014 13:38:01 +0000 Subject: New tests iortrans-4.11* demonstrate what was wrong with the "leaky EOF flag" approach in 8.6.1 and earlier. If each level of the channel stack is to have control over its EOF independently, we have to provide for that, even though the Filesystem read APIs make it a big pain. Also test robustness against varing buffer sizes. --- tests/ioTrans.test | 89 +++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 85 insertions(+), 4 deletions(-) diff --git a/tests/ioTrans.test b/tests/ioTrans.test index f1fa733..faae9d8 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -597,7 +597,9 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup { rename foo {} } -result {{read rt* {test data }} {}} -test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -setup { + +# Driver for a base channel that emits several short "files" +# with each terminated by a fleeting EOF proc driver {cmd args} { variable buffer variable index @@ -629,6 +631,8 @@ test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -setup { } } } + +# Channel read transform that is just the identity - pass all through proc idxform {cmd handle args} { switch -- $cmd { initialize { @@ -643,15 +647,92 @@ test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -setup { } } } -} -body { + +# Test that all EOFs pass through full xform stack. Proper data boundaries. +# Check robustness against buffer sizes. +test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -body { set chan [chan push [chan create read driver] idxform] list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ [read $chan] [eof $chan] } -cleanup { close $chan - rename idxform {} - rename driver {} } -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.10.1 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + chan configure $chan -buffersize 3 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.10.2 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + chan configure $chan -buffersize 5 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + +rename idxform {} + +# Channel read transform that delays the data + proc delayxform {cmd handle args} { + variable store + switch -- $cmd { + initialize { + set store($handle) {} + return {initialize finalize read drain} + } + finalize { + unset store($handle) + return + } + read { + lassign $args buffer + if {$store($handle) eq {}} { + set reply [string index $buffer 0] + set store($handle) [string range $buffer 1 end] + } else { + set reply $store($handle) + set store($handle) $buffer + } + return $reply + } + drain { + delayxform read $handle {} + } + } + } + +# Test that all EOFs pass through full xform stack. Proper data boundaries. +# Check robustness against buffer sizes. +test iortrans-4.11 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.11.1 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + chan configure $chan -buffersize 3 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.11.2 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + chan configure $chan -buffersize 5 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + + rename delayxform {} + rename driver {} # --- === *** ########################### -- cgit v0.12 From adea67eff68a30658ab99164c4015dc11845de4b Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Thu, 6 Nov 2014 14:52:36 +0000 Subject: Another test checking that handling when transform returns nothing is right. --- tests/ioTrans.test | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/tests/ioTrans.test b/tests/ioTrans.test index faae9d8..aa2fbc7 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -676,7 +676,7 @@ test iortrans-4.10.2 {[5adbc350683] chan read, handle fleeting EOF} -body { rename idxform {} -# Channel read transform that delays the data +# Channel read transform that delays the data and always returns something proc delayxform {cmd handle args} { variable store switch -- $cmd { @@ -732,6 +732,40 @@ test iortrans-4.11.2 {[5adbc350683] chan read, handle fleeting EOF} -body { } -result {0 ..... 1 {} 0 ..... 1} rename delayxform {} + +# Channel read transform that delays the data and may return {} + proc delay2xform {cmd handle args} { + variable store + switch -- $cmd { + initialize { + set store($handle) {} + return {initialize finalize read drain} + } + finalize { + unset store($handle) + return + } + read { + lassign $args buffer + set reply $store($handle) + set store($handle) $buffer + return $reply + } + drain { + delay2xform read $handle {} + } + } + } + +test iortrans-4.12 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delay2xform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + + rename delay2xform {} rename driver {} -- cgit v0.12 From 48dfa4d688675bd1efd021c810fd2d54c990286d Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Thu, 6 Nov 2014 17:34:40 +0000 Subject: cleanup global namespace litter --- tests/ioTrans.test | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/ioTrans.test b/tests/ioTrans.test index aa2fbc7..f82c610 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -613,6 +613,8 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup { finalize { if {![info exists index($chan)]} {return} unset index($chan) buffer($chan) + array unset index + array unset buffer return } watch {} -- cgit v0.12 From f6e375ce7671a7751ab0788c844f2462d9212001 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 7 Nov 2014 13:59:27 +0000 Subject: Make sure all uses of the [testbytestring] command are constrained. --- tests/parse.test | 6 ++++-- tests/parseOld.test | 12 ++++++------ tests/subst.test | 4 ++-- tests/utf.test | 40 ++++++++++++++++++++-------------------- 4 files changed, 32 insertions(+), 30 deletions(-) diff --git a/tests/parse.test b/tests/parse.test index fe6026d..4e3139c 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -303,8 +303,10 @@ test parse-6.16 {ParseTokens procedure, backslash substitution} testparser { testparser {\n\a\x7f} 0 } {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}} test parse-6.17 {ParseTokens procedure, null characters} {testparser testbytestring} { - testparser [testbytestring "foo\0zz"] 0 -} "- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}" + expr {[testparser [testbytestring "foo\0zz"] 0] eq +"- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}" + } +} 1 test parse-6.18 {ParseTokens procedure, seek past numBytes for close-bracket} testparser { # Test for Bug 681841 list [catch {testparser {[a]} 2} msg] $msg diff --git a/tests/parseOld.test b/tests/parseOld.test index 4c08b5d..a6e07a2b 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -263,14 +263,14 @@ test parseOld-7.11 {backslash substitution} { eval "list a \"b c\"\\\nd e" } {a {b c} d e} test parseOld-7.12 {backslash substitution} testbytestring { - list \ua2 -} [testbytestring "\xc2\xa2"] + expr {[list \ua2] eq [testbytestring "\xc2\xa2"]} +} 1 test parseOld-7.13 {backslash substitution} testbytestring { - list \u4e21 -} [testbytestring "\xe4\xb8\xa1"] + expr {[list \u4e21] eq [testbytestring "\xe4\xb8\xa1"]} +} 1 test parseOld-7.14 {backslash substitution} testbytestring { - list \u4e2k -} [testbytestring "\xd3\xa2k"] + expr {[list \u4e2k] eq [testbytestring "\xd3\xa2k"]} +} 1 # Semi-colon. diff --git a/tests/subst.test b/tests/subst.test index 256b7f7..2115772 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -38,8 +38,8 @@ test subst-2.3 {simple strings} { } abcdefg test subst-2.4 {simple strings} testbytestring { # Tcl Bug 685106 - subst [testbytestring bar\x00soom] -} [testbytestring bar\x00soom] + expr {[subst [testbytestring bar\x00soom]] eq [testbytestring bar\x00soom]} +} 1 test subst-3.1 {backslash substitutions} { subst {\x\$x\[foo bar]\\} diff --git a/tests/utf.test b/tests/utf.test index 83daddf..ceb1af7 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -21,23 +21,23 @@ testConstraint testbytestring [llength [info commands testbytestring]] catch {unset x} test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring { - set x \x01 -} [testbytestring "\x01"] + expr {"\x01" eq [testbytestring "\x01"]} +} 1 test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { - set x "\x00" -} [testbytestring "\xc0\x80"] + expr {"\x00" eq [testbytestring "\xc0\x80"]} +} 1 test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { - set x "\xe0" -} [testbytestring "\xc3\xa0"] + expr {"\xe0" eq [testbytestring "\xc3\xa0"]} +} 1 test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring { - set x "\u4e4e" -} [testbytestring "\xe4\xb9\x8e"] + expr {"\u4e4e" eq [testbytestring "\xe4\xb9\x8e"]} +} 1 test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { - format %c 0x110000 -} [testbytestring "\xef\xbf\xbd"] + expr {[format %c 0x110000] eq [testbytestring "\xef\xbf\xbd"]} +} 1 test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { - format %c -1 -} [testbytestring "\xef\xbf\xbd"] + expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]} +} 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" @@ -128,17 +128,17 @@ test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { } { } test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring { - set x \ua2 -} [testbytestring "\xc2\xa2"] + expr {"\ua2" eq [testbytestring "\xc2\xa2"]} +} 1 test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring { - set x \u4e21 -} [testbytestring "\xe4\xb8\xa1"] + expr {"\u4e21" eq [testbytestring "\xe4\xb8\xa1"]} +} 1 test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { - set x \u4e2k -} "[testbytestring \xd3\xa2]k" + expr {"\u4e2k" eq "[testbytestring \xd3\xa2]k"} +} 1 test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { - set x \u4e216 -} "[testbytestring \xe4\xb8\xa1]6" + expr {"\u4e216" eq "[testbytestring \xe4\xb8\xa1]6"} +} 1 proc bsCheck {char num} { global errNum test utf-10.$errNum {backslash substitution} { -- cgit v0.12 From 4d52a7e8fdd4f8657b35d0f11618a5136b9045b9 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 7 Nov 2014 14:10:23 +0000 Subject: update changes; more test suite polishing. --- changes | 10 +++++++++- tests/parse.test | 2 +- tests/socket.test | 2 +- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/changes b/changes index 03184e4..945b167 100644 --- a/changes +++ b/changes @@ -8482,4 +8482,12 @@ include ::oo::class (fellows) 2014-10-18 (bug)[10dc6d] fix [gets] on non-blocking channels (fassel,porter) ---- Released 8.6.3, October 29, 2014 --- http://core.tcl.tk/tcl/ for details +2014-10-26 Support for Windows 10 (nijtmans) + +2014-10-31 (bug)[dcc034] restore [open comX: r+] (lll,nijtmans) + +2014-11-05 (bug)[214cc0] Restore [lappend v] return value (sayers,porter) + +2014-11-06 (bug)[5adc35] Stop forcing EOF to be permanent (porter) + +--- Released 8.6.3, November 12, 2014 --- http://core.tcl.tk/tcl/ for details diff --git a/tests/parse.test b/tests/parse.test index 4e3139c..5d8afeb 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -918,7 +918,7 @@ test parse-15.57 {CommandComplete procedure} { test parse-15.58 {CommandComplete procedure, memory leaks} { info complete "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22" } 1 -test parse-15.59 {CommandComplete procedure} { +test parse-15.59 {CommandComplete procedure} testbytestring { # Test for Tcl Bug 684744 info complete [testbytestring "\x00;if 1 \{"] } 0 diff --git a/tests/socket.test b/tests/socket.test index d6cee30..eeea044 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -2249,7 +2249,7 @@ test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener unset x } -result {socket is not connected} -returnCodes 1 test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ - -constraints {socket} \ + -constraints {socket nonportable} \ -body { set sock [socket -async localhost [randport]] fconfigure $sock -blocking 0 -- cgit v0.12 From 183456434909ef2033e31b6c23e8c80fa213b7dc Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Fri, 7 Nov 2014 17:48:31 +0000 Subject: Correct -singleproc 1 testing flaws. --- tests/interp.test | 4 ++-- tests/ioTrans.test | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/interp.test b/tests/interp.test index ad99fac..4bc9fe2 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -3615,10 +3615,10 @@ test interp-38.3 {interp debug wrong args} -body { } -returnCodes { error } -result {wrong # args: should be "interp debug path ?-frame ?bool??"} -test interp-38.4 {interp debug basic setup} -body { +test interp-38.4 {interp debug basic setup} -constraints {!singleTestInterp} -body { interp debug {} } -result {-frame 0} -test interp-38.5 {interp debug basic setup} -body { +test interp-38.5 {interp debug basic setup} -constraints {!singleTestInterp} -body { interp debug {} -f } -result {0} test interp-38.6 {interp debug basic setup} -body { diff --git a/tests/ioTrans.test b/tests/ioTrans.test index f82c610..e179eab 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -601,8 +601,8 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup { # Driver for a base channel that emits several short "files" # with each terminated by a fleeting EOF proc driver {cmd args} { - variable buffer - variable index + variable ::tcl::buffer + variable ::tcl::index set chan [lindex $args 0] switch -- $cmd { initialize { -- cgit v0.12 From 0899db6b74a75e405fc304c4d76c5497b6b5bf92 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Sat, 8 Nov 2014 07:06:52 +0000 Subject: [214cc0eb22] Add tests to make sure that this bug stays fixed. --- tests/append.test | 17 +++++++++++++++++ tests/appendComp.test | 21 +++++++++++++++++++++ 2 files changed, 38 insertions(+) diff --git a/tests/append.test b/tests/append.test index 69c6381..8fa4e61 100644 --- a/tests/append.test +++ b/tests/append.test @@ -292,6 +292,23 @@ test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env } -cleanup { unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} + +test append-10.1 {Bug 214cc0eb22: lappend with no values} { + set lst "# 1 2 3" + [subst lappend] lst +} "# 1 2 3" +test append-10.2 {Bug 214cc0eb22: lappend with no values} -body { + set lst "1 \{ 2" + [subst lappend] lst +} -returnCodes error -result {unmatched open brace in list} +test append-10.3 {Bug 214cc0eb22: expanded lappend with no values} { + set lst "# 1 2 3" + [subst lappend] lst {*}[list] +} "# 1 2 3" +test append-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body { + set lst "1 \{ 2" + [subst lappend] lst {*}[list] +} -returnCodes error -result {unmatched open brace in list} unset -nocomplain i x result y catch {rename foo ""} diff --git a/tests/appendComp.test b/tests/appendComp.test index f85c3ba..bbf5f9c 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -438,6 +438,27 @@ test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing } -cleanup { unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} + +test appendComp-10.1 {Bug 214cc0eb22: lappend with no values} { + apply {lst { + lappend lst + }} "# 1 2 3" +} "# 1 2 3" +test appendComp-10.2 {Bug 214cc0eb22: lappend with no values} -body { + apply {lst { + lappend lst + }} "1 \{ 2" +} -returnCodes error -result {unmatched open brace in list} +test appendComp-10.3 {Bug 214cc0eb22: expanded lappend with no values} { + apply {lst { + lappend lst {*}[list] + }} "# 1 2 3" +} "# 1 2 3" +test appendComp-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body { + apply {lst { + lappend lst {*}[list] + }} "1 \{ 2" +} -returnCodes error -result {unmatched open brace in list} catch {unset i x result y} catch {rename foo ""} -- cgit v0.12 From 48dc76cee5543eb7288db16897652fa910a99809 Mon Sep 17 00:00:00 2001 From: "dgp@users.sourceforge.net" Date: Tue, 11 Nov 2014 22:23:57 +0000 Subject: Likely fix for channel mem leaks. --- generic/tclIO.c | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 8ec2a1e..2025742 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -155,6 +155,7 @@ static ChannelBuffer * AllocChannelBuffer(int length); static void PreserveChannelBuffer(ChannelBuffer *bufPtr); static void ReleaseChannelBuffer(ChannelBuffer *bufPtr); static int IsShared(ChannelBuffer *bufPtr); +static void ChannelFree(Channel *chanPtr); static void ChannelTimerProc(ClientData clientData); static int ChanRead(Channel *chanPtr, char *dst, int dstSize); static int CheckChannelErrors(ChannelState *statePtr, @@ -1914,6 +1915,16 @@ TclChannelRelease( } } +static void +ChannelFree( + Channel *chanPtr) +{ + if (chanPtr->refCount == 0) { + ckfree(chanPtr); + return; + } + chanPtr->typePtr = NULL; +} /* *---------------------------------------------------------------------- @@ -2060,7 +2071,7 @@ Tcl_UnstackChannel( */ result = ChanClose(chanPtr, interp); - chanPtr->typePtr = NULL; + ChannelFree(chanPtr); UpdateInterest(statePtr->topChanPtr); @@ -3018,7 +3029,8 @@ CloseChannel( statePtr->topChanPtr = downChanPtr; downChanPtr->upChanPtr = NULL; - chanPtr->typePtr = NULL; + + ChannelFree(chanPtr); return Tcl_Close(interp, (Tcl_Channel) downChanPtr); } @@ -3029,7 +3041,7 @@ CloseChannel( * stack, make sure to free the ChannelState structure associated with it. */ - chanPtr->typePtr = NULL; + ChannelFree(chanPtr); Tcl_EventuallyFree(statePtr, TCL_DYNAMIC); -- cgit v0.12 From 1f4accd1359f98e82dfd8a9e5c4ee70fc22e141d Mon Sep 17 00:00:00 2001 From: "nijtmans@users.sourceforge.net" Date: Thu, 13 Nov 2014 16:08:47 +0000 Subject: Simplify NativeIsComPort() implementation: native paths never end in ':', and never use forward slashes (any more), so no need to check for that. --- win/tclWinChan.c | 32 ++++++++++++-------------------- 1 file changed, 12 insertions(+), 20 deletions(-) diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 2d6c42c..cca0dab 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -971,7 +971,7 @@ TclpOpenFileChannel( switch (FileGetType(handle)) { case FILE_TYPE_SERIAL: /* - * Natively named serial ports "com1-9", "\\\\.\\comXX" are + * Natively named serial ports "com1-9", "\\\\.\\comXX" are * already done with the code above. * Here we handle all other serial port names. * @@ -1525,12 +1525,11 @@ FileGetType( * NativeIsComPort -- * * Determines if a path refers to a Windows serial port. - * A simple and efficient solution is to use a "name hint" to detect - * COM ports by their filename instead of resorting to a syscall + * A simple and efficient solution is to use a "name hint" to detect + * COM ports by their filename instead of resorting to a syscall * to detect serialness after the fact. * The following patterns cover common serial port names: - * COM[1-9]:? - * //./COM[0-9]+ + * COM[1-9] * \\.\COM[0-9]+ * * Results: @@ -1550,33 +1549,26 @@ NativeIsComPort( * 1. Look for com[1-9]:? */ - if ( (len >= 4) && (len <= 5) - && (_wcsnicmp(p, L"com", 3) == 0) ) { + if ( (len == 4) && (_wcsnicmp(p, L"com", 3) == 0) ) { /* - * The 4th character must be a digit 1..9 optionally followed by a ":" + * The 4th character must be a digit 1..9 */ - + if ( (p[3] < L'1') || (p[3] > L'9') ) { return 0; } - if ( (len == 5) && (p[4] != L':') ) { - return 0; - } return 1; } - + /* - * 2. Look for //./com[0-9]+ or \\.\com[0-9]+ + * 2. Look for \\.\com[0-9]+ */ - - if ( (len >= 8) && ( - (_wcsnicmp(p, L"//./com", 7) == 0) - || (_wcsnicmp(p, L"\\\\.\\com", 7) == 0) ) ) - { + + if ((len >= 8) && (_wcsnicmp(p, L"\\\\.\\com", 7) == 0)) { /* * Charaters 8..end must be a digits 0..9 */ - + for ( i=7; i '9') ) { return 0; -- cgit v0.12 From 635520e15497f1118c2c447befd2baea2c20e7a8 Mon Sep 17 00:00:00 2001 From: "nijtmans@users.sourceforge.net" Date: Fri, 14 Nov 2014 09:44:34 +0000 Subject: Remove a number of eol-spaces. No change in functionality. --- changes | 6 ++-- license.terms | 4 +-- macosx/configure.ac | 2 +- pkgs/README | 4 +-- unix/ldAix | 6 ++-- unix/tcl.spec | 2 +- unix/tclUnixChan.c | 8 ++--- unix/tclUnixInit.c | 2 +- unix/tclUnixPipe.c | 4 +-- unix/tclUnixSock.c | 50 ++++++++++++++--------------- unix/tclUnixThrd.h | 2 +- unix/tclUnixTime.c | 2 +- win/tclConfig.sh.in | 2 +- win/tclWinConsole.c | 2 +- win/tclWinSerial.c | 2 +- win/tclWinSock.c | 90 ++++++++++++++++++++++++++--------------------------- 16 files changed, 94 insertions(+), 94 deletions(-) diff --git a/changes b/changes index 945b167..1decfe2 100644 --- a/changes +++ b/changes @@ -8303,11 +8303,11 @@ reported usage of large expressions (porter) Many optmizations, improvements, and tightened stack management in bytecode. ---- Released 8.6.1, September 20, 2013 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.1, September 20, 2013 --- http://core.tcl.tk/tcl/ for details 2013-09-27 (enhancement) improved ::env synchronization (fellows) -2013-10-20 (bug fix)[2835313] segfault from +2013-10-20 (bug fix)[2835313] segfault from [apply {{} {while 1 {a {*}[return -level 0 -code continue]}}}] (fellows) 2013-10-22 (bug fix)[3556215] [scan %E%G%X] support (fellows) @@ -8451,7 +8451,7 @@ include ::oo::class (fellows) 2014-08-25 (TIP 429) New command [string cat] (leitgeb,ferrieux) ---- Released 8.6.2, August 27, 2014 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.2, August 27, 2014 --- http://core.tcl.tk/tcl/ for details 2014-08-28 (bug)[b9e1a3] Correct Method Search Order (nadkarni,fellows) => TclOO 1.0.3 diff --git a/license.terms b/license.terms index 164d65e..d8049cd 100644 --- a/license.terms +++ b/license.terms @@ -29,7 +29,7 @@ MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" -in the software and related documentation as defined in the Federal +in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the @@ -37,4 +37,4 @@ Government shall have only "Restricted Rights" as defined in Clause 252.227-7014 (b) (3) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the -terms specified in this license. +terms specified in this license. diff --git a/macosx/configure.ac b/macosx/configure.ac index 01c3697..f7a8bb3 100644 --- a/macosx/configure.ac +++ b/macosx/configure.ac @@ -3,7 +3,7 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. -dnl Ensure that the config (auto)headers support is used, then just +dnl Ensure that the config (auto)headers support is used, then just dnl include the configure sources from ../unix: m4_include(../unix/aclocal.m4) diff --git a/pkgs/README b/pkgs/README index 868bd4f..159a237 100644 --- a/pkgs/README +++ b/pkgs/README @@ -36,14 +36,14 @@ needs to conform to the following conventions. clean: Delete all files generated by the default build target. - distclean: Delete all generated files. + distclean: Delete all generated files. dist: Produce a copy of the package's source code distribution. Must respect the DIST_ROOT variable determining where to write the generated directory. Packages that are written to make use of the Tcl Extension Architecture (TEA) -and that make use of the tclconfig collection of support files, should +and that make use of the tclconfig collection of support files, should conform to these conventions without further efforts. These conventions are subject to revision and refinement over time to diff --git a/unix/ldAix b/unix/ldAix index 51b2995..f115ea8 100755 --- a/unix/ldAix +++ b/unix/ldAix @@ -1,5 +1,5 @@ #!/bin/sh -# +# # ldAix ldCmd ldArg ldArg ... # # This shell script provides a wrapper for ld under AIX in order to @@ -40,8 +40,8 @@ rm -f lib.exp echo "#! $outputFile" >lib.exp /usr/ccs/bin/nm $nmopts $ofiles | sed -e '/:$/d' -e '/ U /d' -e 's/^\.//' -e 's/[ |].*//' | sort | uniq >>lib.exp -# If we're linking a .a file, then link all the objects together into a -# single file "shr.o" and then put that into the archive. Otherwise link +# If we're linking a .a file, then link all the objects together into a +# single file "shr.o" and then put that into the archive. Otherwise link # the object files directly into the .a file. noDotA=`echo $outputFile | sed -e '/\.a$/d'` diff --git a/unix/tcl.spec b/unix/tcl.spec index d660f74..81f31da 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -30,7 +30,7 @@ CFLAGS="%optflags" ./configure \ --prefix=%{directory} \ --exec-prefix=%{directory} \ --libdir=%{directory}/%{_lib} -make +make %install cd unix diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 2eca714..a1fe090 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -792,7 +792,7 @@ TtySetOptionProc( * * Results: * A standard Tcl result. Also sets the supplied DString to the string - * value of the option(s) returned. Sets error message if needed + * value of the option(s) returned. Sets error message if needed * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- @@ -1201,7 +1201,7 @@ TtyParseMode( char parity; const char *bad = "bad value for -mode"; - i = sscanf(mode, "%d,%c,%d,%d%n", + i = sscanf(mode, "%d,%c,%d,%d%n", &ttyPtr->baud, &parity, &ttyPtr->data, @@ -1292,7 +1292,7 @@ TtyInit( || iostate.c_lflag != 0 || iostate.c_cflag & CREAD || iostate.c_cc[VMIN] != 1 - || iostate.c_cc[VTIME] != 0) + || iostate.c_cc[VTIME] != 0) { iostate.c_iflag = IGNBRK; iostate.c_oflag = 0; @@ -1824,7 +1824,7 @@ TclUnixWaitForFile( if (FD_ISSET(fd, &writableMask)) { SET_BITS(result, TCL_WRITABLE); } - if (FD_ISSET(fd, &exceptionMask)) { + if (FD_ISSET(fd, &exceptionMask)) { SET_BITS(result, TCL_EXCEPTION); } result &= mask; diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 1617cba..520c8e5 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -768,7 +768,7 @@ TclpSetVariables( */ CFLocaleRef localeRef; - + if (CFLocaleCopyCurrent != NULL && CFLocaleGetIdentifier != NULL && (localeRef = CFLocaleCopyCurrent())) { CFStringRef locale = CFLocaleGetIdentifier(localeRef); diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 95bc8d1..8b26694 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -261,7 +261,7 @@ TclpTempFileName(void) * * On Unix, it works to load a shared object from a file of any name, so this * function is merely a thin wrapper around TclpTempFileName(). - * + * *---------------------------------------------------------------------------- */ @@ -969,7 +969,7 @@ PipeClose2Proc( pipePtr->outFile = NULL; } } - + /* * If half-closing, stop here. */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index d06e7f1..0188ea6 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -438,11 +438,11 @@ WaitForConnect( /* * Check if an async connect is running. If not return ok */ - + if (!(statePtr->flags & TCP_ASYNC_PENDING)) { return 0; } - + if (errorCodePtr == NULL || (statePtr->flags & TCP_NONBLOCKING)) { timeout = 0; } else { @@ -601,7 +601,7 @@ TcpCloseProc( * handlers are already deleted in the generic IO channel closing code * that called this function, so we do not have to delete them here. */ - + for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { if (fds->fd < 0) { continue; @@ -610,7 +610,7 @@ TcpCloseProc( if (close(fds->fd) < 0) { errorCode = errno; } - + } fds = statePtr->fds.next; while (fds != NULL) { @@ -974,7 +974,7 @@ TcpWatchProc( */ return; } - + if (statePtr->flags & TCP_ASYNC_PENDING) { /* Async sockets use a FileHandler internally while connecting, so we * need to cache this request until the connection has succeeded. */ @@ -1111,7 +1111,7 @@ TcpConnect( for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; statePtr->myaddr = statePtr->myaddr->ai_next) { int reuseaddr = 1; - + /* * No need to try combinations of local and remote addresses of * different families. @@ -1141,15 +1141,15 @@ TcpConnect( * Set the close-on-exec flag so that the socket will not get * inherited by child processes. */ - + fcntl(statePtr->fds.fd, F_SETFD, FD_CLOEXEC); - + /* * Set kernel space buffering */ - + TclSockMinimumBuffers(INT2PTR(statePtr->fds.fd), SOCKET_BUFSIZE); - + if (async) { ret = TclUnixSetBlockingMode(statePtr->fds.fd,TCL_MODE_NONBLOCKING); if (ret < 0) { @@ -1160,7 +1160,7 @@ TcpConnect( /* Gotta reset the error variable here, before we use it for the * first time in this iteration. */ error = 0; - + (void) setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr, @@ -1176,7 +1176,7 @@ TcpConnect( * will set up a file handler on the socket if she is interested * in being informed when the connect completes. */ - + ret = connect(statePtr->fds.fd, statePtr->addr->ai_addr, statePtr->addr->ai_addrlen); if (ret < 0) error = errno; @@ -1459,28 +1459,28 @@ Tcl_OpenTcpServer( } continue; } - + /* * Set the close-on-exec flag so that the socket will not get * inherited by child processes. */ - + fcntl(sock, F_SETFD, FD_CLOEXEC); - + /* * Set kernel space buffering */ - + TclSockMinimumBuffers(INT2PTR(sock), SOCKET_BUFSIZE); - + /* * Set up to reuse server addresses automatically and bind to the * specified port. */ - - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, + + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); - + /* * Make sure we use the same port number when opening two server * sockets for IPv4 and IPv6 on a random port. @@ -1509,7 +1509,7 @@ Tcl_OpenTcpServer( if (howfar < BIND) { howfar = BIND; my_errno = errno; - } + } close(sock); sock = -1; continue; @@ -1541,7 +1541,7 @@ Tcl_OpenTcpServer( /* * Allocate a new TcpState for this socket. */ - + statePtr = ckalloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->acceptProc = acceptProc; @@ -1556,12 +1556,12 @@ Tcl_OpenTcpServer( newfds->fd = sock; newfds->statePtr = statePtr; fds = newfds; - + /* * Set up the callback mechanism for accepting connections from new * clients. */ - + Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds); } @@ -1620,7 +1620,7 @@ TcpAccept( socklen_t len; /* For accept interface */ char channelName[SOCK_CHAN_LENGTH]; char host[NI_MAXHOST], port[NI_MAXSERV]; - + len = sizeof(addr); newsock = accept(fds->fd, &addr.sa, &len); if (newsock < 0) { diff --git a/unix/tclUnixThrd.h b/unix/tclUnixThrd.h index 6a73132..f03b530 100644 --- a/unix/tclUnixThrd.h +++ b/unix/tclUnixThrd.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ - + #ifndef _TCLUNIXTHRD #define _TCLUNIXTHRD diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 4452022..315bcf9 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -199,7 +199,7 @@ TclpWideClicksToNanoseconds( #ifdef MAC_OSX_TCL static mach_timebase_info_data_t tb; static uint64_t maxClicksForUInt64; - + if (!tb.denom) { mach_timebase_info(&tb); maxClicksForUInt64 = UINT64_MAX / tb.numer; diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in index 00a8790..75324b2 100644 --- a/win/tclConfig.sh.in +++ b/win/tclConfig.sh.in @@ -1,5 +1,5 @@ # tclConfig.sh -- -# +# # This shell script (for sh) is generated automatically by Tcl's # configure script. It will create shell variables for most of # the configuration options discovered by the configure script. diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 6630083..63150ef 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -761,7 +761,7 @@ ConsoleInputProc( * by the caller. In practice this is harmless, since all writes * are into ChannelBuffers, and those have padding, but still * ought to remove this, unless some Windows wizard can give - * a reason not to. + * a reason not to. */ buf[count] = '\0'; return count; diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 6487fe4..0730a46 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1415,7 +1415,7 @@ SerialWriterThread( * Opens or Reopens the serial port with the OVERLAPPED FLAG set * * Results: - * Returns the new handle, or INVALID_HANDLE_VALUE. + * Returns the new handle, or INVALID_HANDLE_VALUE. * If an existing channel is specified it is closed and reopened. * * Side effects: diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 66df291..2c58224 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -596,7 +596,7 @@ WaitForConnect( /* * Check if an async connect is running. If not return ok */ - + if (!(statePtr->flags & TCP_ASYNC_CONNECT)) { return 0; } @@ -616,7 +616,7 @@ WaitForConnect( /* get statePtr lock */ tsdPtr = TclThreadDataKeyGet(&dataKey); WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - + /* Check for connect event */ if (statePtr->readyEvents & FD_CONNECT) { @@ -1250,7 +1250,7 @@ TcpGetOptionProc( return TCL_ERROR; } - /* + /* * Go one step in async connect * If any error is thrown save it as backround error to report eventually below */ @@ -1647,14 +1647,14 @@ TcpConnect( /* We were called by the event procedure and continue our loop */ int async_callback = statePtr->flags & TCP_ASYNC_PENDING; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - + if (async_callback) { goto reenter; } - + for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; statePtr->addr = statePtr->addr->ai_next) { - + for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; statePtr->myaddr = statePtr->myaddr->ai_next) { @@ -1670,7 +1670,7 @@ TcpConnect( /* * Close the socket if it is still open from the last unsuccessful * iteration. - */ + */ if (statePtr->sockets->fd != INVALID_SOCKET) { closesocket(statePtr->sockets->fd); } @@ -1683,9 +1683,9 @@ TcpConnect( */ statePtr->notifierConnectError = 0; Tcl_SetErrno(0); - + statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0); - + /* Free list lock */ SetEvent(tsdPtr->socketListLock); @@ -1754,7 +1754,7 @@ TcpConnect( * thread. */ statePtr->selectEvents |= FD_CONNECT; - + /* * Free list lock */ @@ -1768,7 +1768,7 @@ TcpConnect( /* * Attempt to connect to the remote socket. */ - + connect(statePtr->sockets->fd, statePtr->addr->ai_addr, statePtr->addr->ai_addrlen); @@ -1809,7 +1809,7 @@ TcpConnect( * the FD_CONNECT asyncroneously */ tsdPtr->pendingTcpState = NULL; - + if (Tcl_GetErrno() == 0) { goto out; } @@ -1835,12 +1835,12 @@ out: * Set up the select mask for read/write events. */ statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; - + /* * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. */ - + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) statePtr); } else { @@ -2092,20 +2092,20 @@ Tcl_OpenTcpServer( TclWinConvertError((DWORD) WSAGetLastError()); continue; } - + /* * Win-NT has a misfeature that sockets are inherited in child * processes by default. Turn off the inherit bit. */ - + SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); - + /* * Set kernel space buffering */ - + TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); - + /* * Make sure we use the same port when opening two server sockets * for IPv4 and IPv6. @@ -2113,12 +2113,12 @@ Tcl_OpenTcpServer( * As sockaddr_in6 uses the same offset and size for the port * member as sockaddr_in, we can handle both through the IPv4 API. */ - + if (port == 0 && chosenport != 0) { ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = htons(chosenport); } - + /* * Bind to the specified port. Note that we must not call * setsockopt with SO_REUSEADDR because Microsoft allows addresses @@ -2128,7 +2128,7 @@ Tcl_OpenTcpServer( * set into nonblocking mode. If there is trouble, this is one * place to look for bugs. */ - + if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); @@ -2138,29 +2138,29 @@ Tcl_OpenTcpServer( if (port == 0 && chosenport == 0) { address sockname; socklen_t namelen = sizeof(sockname); - + /* * Synchronize port numbers when binding to port 0 of multiple * addresses. */ - + if (getsockname(sock, &sockname.sa, &namelen) >= 0) { chosenport = ntohs(sockname.sa4.sin_port); } } - + /* * Set the maximum number of pending connect requests to the max * value allowed on each platform (Win32 and Win32s may be * different, and there may be differences between TCP/IP stacks). */ - + if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); closesocket(sock); continue; } - + if (statePtr == NULL) { /* * Add this socket to the global list of sockets. @@ -2186,9 +2186,9 @@ error: /* * Set up the select mask for connection request events. */ - + statePtr->selectEvents = FD_ACCEPT; - + /* * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. @@ -2652,7 +2652,7 @@ SocketEventProc( WaitForConnect(statePtr,NULL); } else { - + /* * No async connect reenter pending. Just clear event. */ @@ -2681,7 +2681,7 @@ SocketEventProc( * network stack conditions that can result in FD_ACCEPT but a subsequent * failure on accept() by the time we get around to it. * Access to sockets (acceptEventCount, readyEvents) in socketList - * is still protected by the lock (prevents reintroduction of + * is still protected by the lock (prevents reintroduction of * SF Tcl Bug 3056775. */ @@ -2713,9 +2713,9 @@ SocketEventProc( return 1; } - /* Loop terminated with no sockets accepted; clear the ready mask so - * we can detect the next connection request. Note that connection - * requests are level triggered, so if there is a request already + /* Loop terminated with no sockets accepted; clear the ready mask so + * we can detect the next connection request. Note that connection + * requests are level triggered, so if there is a request already * pending, a new event will be generated. */ statePtr->acceptEventCount = 0; @@ -2758,7 +2758,7 @@ SocketEventProc( if ( statePtr->flags & TCP_ASYNC_FAILED ) { mask |= TCL_READABLE; - + } else { fd_set readFds; struct timeval timeout; @@ -2796,11 +2796,11 @@ SocketEventProc( if (events & FD_WRITE) { mask |= TCL_WRITABLE; } - + /* * Call registered event procedures */ - + if (mask) { Tcl_NotifyChannel(statePtr->channel, mask); } @@ -2812,7 +2812,7 @@ SocketEventProc( * * AddSocketInfoFd -- * - * This function adds a SOCKET file descriptor to the 'sockets' linked + * This function adds a SOCKET file descriptor to the 'sockets' linked * list of a TcpState structure. * * Results: @@ -2826,7 +2826,7 @@ SocketEventProc( static void AddSocketInfoFd( - TcpState *statePtr, + TcpState *statePtr, SOCKET socket) { TcpFdList *fds = statePtr->sockets; @@ -2840,7 +2840,7 @@ AddSocketInfoFd( while ( fds->next != NULL ) { fds = fds->next; } - + fds->next = ckalloc(sizeof(TcpFdList)); fds = fds->next; } @@ -2851,7 +2851,7 @@ AddSocketInfoFd( fds->next = NULL; } - + /* *---------------------------------------------------------------------- * @@ -2935,7 +2935,7 @@ WaitForSocketEvent( /* get statePtr lock */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - + /* Check if event occured */ event_found = (statePtr->readyEvents & events); @@ -2946,7 +2946,7 @@ WaitForSocketEvent( if (event_found) { break; } - + /* Exit loop if event did not occur but this is a non-blocking channel */ if (statePtr->flags & TCP_NONBLOCKING) { *errorCodePtr = EWOULDBLOCK; @@ -3313,11 +3313,11 @@ TcpThreadActionProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); statePtr->nextPtr = tsdPtr->socketList; tsdPtr->socketList = statePtr; - + if (statePtr == tsdPtr->pendingTcpState) { tsdPtr->pendingTcpState = NULL; } - + SetEvent(tsdPtr->socketListLock); notifyCmd = SELECT; -- cgit v0.12 From 1c78dbe1e50f1a8aa77f3830a1162a7347788f76 Mon Sep 17 00:00:00 2001 From: "nijtmans@users.sourceforge.net" Date: Fri, 21 Nov 2014 13:05:31 +0000 Subject: Fix [743338466549f09e3956d8a86e6f9a8030f227cb|7433384665]: socket error encoding bug. --- generic/tclIOSock.c | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 694501f..f69d30f 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -12,9 +12,26 @@ #include "tclInt.h" #if defined(_WIN32) && defined(UNICODE) -/* On Windows, we always need the ASCII version. */ -# undef gai_strerror -# define gai_strerror gai_strerrorA +/* On Windows, we need to do proper Unicode->UTF-8 conversion. */ + +typedef struct ThreadSpecificData { + int initialized; + Tcl_DString errorMsg; /* UTF-8 encoded error-message */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + +#undef gai_strerror +static const char *gai_strerror(int code) { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->initialized) { + Tcl_DStringFree(&tsdPtr->errorMsg); + } else { + tsdPtr->initialized = 1; + } + Tcl_WinTCharToUtf(gai_strerrorW(code), -1, &tsdPtr->errorMsg); + return Tcl_DStringValue(&tsdPtr->errorMsg); +} #endif /* -- cgit v0.12 From 5e7548e7593ca8cc9455c1e4e8652ef98feca5b2 Mon Sep 17 00:00:00 2001 From: andreask Date: Mon, 1 Dec 2014 20:17:04 +0000 Subject: Fix missing export of the "NewForeachInfoType" AuxData structure for tbcload/tclcompiler packages. --- generic/tclCompile.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 3736498..0f4dfaf 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -4342,10 +4342,11 @@ TclInitAuxDataTypeTable(void) Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); /* - * There are only three AuxData types at this time, so register them here. + * There are only four AuxData types at this time, so register them here. */ RegisterAuxDataType(&tclForeachInfoType); + RegisterAuxDataType(&tclNewForeachInfoType); RegisterAuxDataType(&tclJumptableInfoType); RegisterAuxDataType(&tclDictUpdateInfoType); } -- cgit v0.12 From 4aaf301d5477a157851b7b97e0b256a3fc9df4e9 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Wed, 3 Dec 2014 13:22:53 +0000 Subject: adding a test for the bug --- tests/compile.test | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/tests/compile.test b/tests/compile.test index 22ebc7d..8150622 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -455,14 +455,22 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} { list [catch {exec [interpreter] << $script} msg] $msg } {0 OK} -# Special test for compiling tokens from a copy of the source string. [Bug -# 599788] +# Tests compile-14.* for compiling tokens from a copy of the source string. +# [Bug 599788] [Bug 0c043a175a47da8c2342] test compile-14.1 {testing errors in element name; segfault?} {} { catch {set a([error])} msg1 catch {set bubba([join $abba $jubba]) $vol} msg2 list $msg1 $msg2 } {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}} +test compile-14.2 {testing element name "$"} -body { + unset a + set a() 1 + set a($) 2 + list [set a()] [set a($)] [unset a(); lindex [array names a] 0] +} -cleanup {unset a} -result {1 2 $} + + # Tests compile-15.* cover Tcl Bug 633204 test compile-15.1 {proper TCL_RETURN code from [return]} { apply {{} {catch return}} -- cgit v0.12 From b4d1b4c77f545a09a47bdfaa7824571ac33bca33 Mon Sep 17 00:00:00 2001 From: "donal.k.fellows@manchester.ac.uk" Date: Wed, 3 Dec 2014 23:05:15 +0000 Subject: [0dca3bfa8f] Strengthen validity checks on fast-path string comparison. --- generic/tclExecute.c | 8 +++++--- tests/stringComp.test | 8 ++++++++ 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 337a75f..b9da8fc 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5410,8 +5410,8 @@ TEBCresume( s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); memCmpFn = memcmp; - } else if (((valuePtr->typePtr == &tclStringType) - && (value2Ptr->typePtr == &tclStringType))) { + } else if ((valuePtr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &tclStringType)) { /* * Do a unicode-specific comparison if both of the args are of * String type. If the char length == byte length, we can do a @@ -5422,7 +5422,9 @@ TEBCresume( s1len = Tcl_GetCharLength(valuePtr); s2len = Tcl_GetCharLength(value2Ptr); if ((s1len == valuePtr->length) - && (s2len == value2Ptr->length)) { + && (valuePtr->bytes != NULL) + && (s2len == value2Ptr->length) + && (value2Ptr->bytes != NULL)) { s1 = valuePtr->bytes; s2 = value2Ptr->bytes; memCmpFn = memcmp; diff --git a/tests/stringComp.test b/tests/stringComp.test index f9f6bda..a66525e 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -720,6 +720,14 @@ test stringComp-14.2 {Bug 82e7f67325} memory { }} {a b} } } {0} +test stringComp-14.3 {Bug 0dca3bfa8f} { + apply {arg { + set argCopy $arg + set arg [string replace $arg 1 2 aa] + # Crashes in comparison before fix + expr {$arg ne $argCopy} + }} abcde +} 1 ## string tolower ## not yet bc -- cgit v0.12 From f6c9faf105b9c7abfaac764326f1b1b51c4d5897 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Wed, 3 Dec 2014 23:17:16 +0000 Subject: test and fix (thx dgp) --- generic/tclCompCmds.c | 2 +- tests/compile.test | 9 +++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 18f4564..4e7ef97 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3373,7 +3373,7 @@ TclPushVarName( nameChars = p - varTokenPtr[1].start; elName = p + 1; remainingChars = (varTokenPtr[2].start - p) - 1; - elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2; + elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1; if (remainingChars) { /* diff --git a/tests/compile.test b/tests/compile.test index 8150622..45d69e9 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -464,11 +464,12 @@ test compile-14.1 {testing errors in element name; segfault?} {} { } {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}} test compile-14.2 {testing element name "$"} -body { - unset a + unset -nocomplain a set a() 1 - set a($) 2 - list [set a()] [set a($)] [unset a(); lindex [array names a] 0] -} -cleanup {unset a} -result {1 2 $} + set a(1) 2 + set a($) 3 + list [set a()] [set a(1)] [set a($)] [unset a(); lindex [array names a] 0] +} -cleanup {unset a} -result [list 1 2 3 {$}] # Tests compile-15.* cover Tcl Bug 633204 -- cgit v0.12 From 0bc29bb99d63fee8c4cd115619da3010bc565858 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Wed, 3 Dec 2014 23:34:36 +0000 Subject: missing unset in new test --- tests/compile.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/compile.test b/tests/compile.test index 45d69e9..7335293 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -468,7 +468,7 @@ test compile-14.2 {testing element name "$"} -body { set a() 1 set a(1) 2 set a($) 3 - list [set a()] [set a(1)] [set a($)] [unset a(); lindex [array names a] 0] + list [set a()] [set a(1)] [set a($)] [unset a() a(1); lindex [array names a] 0] } -cleanup {unset a} -result [list 1 2 3 {$}] -- cgit v0.12