From 8aa1ab62e1501d779f07a7c0df073f852b5dce4d Mon Sep 17 00:00:00 2001 From: dkf 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 6d413075c9b687f662acd3d1f4fcef7e34f386e7 Mon Sep 17 00:00:00 2001 From: dkf 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 c2d32899a05265e34d4c88dc6035c01f866dbfb0 Mon Sep 17 00:00:00 2001 From: dkf 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 5318e02134708884c49c74419b36f34da125b85f Mon Sep 17 00:00:00 2001 From: dkf 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 60c48207275926d160a50ab91108f28ae7475040 Mon Sep 17 00:00:00 2001 From: dkf 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 2859532759626d4782896f4c151bf58a668da85b Mon Sep 17 00:00:00 2001 From: dkf 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 c688c0e2b32e29091cb41f2ef425fe3cafa39c19 Mon Sep 17 00:00:00 2001 From: dkf 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 7bb34adfdb3692426a742497b53ccc8ae43b4892 Mon Sep 17 00:00:00 2001 From: dgp 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 496282eb49d6e1f93e445ed27bbdefda520a1dc5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 1 Sep 2014 08:11:52 +0000 Subject: Combine TCL_SHLIB_LD_EXTRAS+TK_SHLIB_LD_EXTRAS (for Cygwin and FreeBSD) to a single SHLIB_LD_LIBS usable for both Tcl and Tk. --- unix/configure | 6 ++---- unix/tcl.m4 | 6 ++---- 2 files changed, 4 insertions(+), 8 deletions(-) diff --git a/unix/configure b/unix/configure index e4ff106..d11e7d2 100755 --- a/unix/configure +++ b/unix/configure @@ -6938,8 +6938,7 @@ fi LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' - TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a' - TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a' + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5 echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6 if test "${ac_cv_cygwin+set}" = set; then @@ -7644,8 +7643,7 @@ fi # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" - TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$@" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index b6c86b6..437ce3d 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1246,8 +1246,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' - TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' - TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" AC_CACHE_CHECK(for Cygwin version of gcc, ac_cv_cygwin, AC_TRY_COMPILE([ @@ -1555,8 +1554,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" - TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$[@]" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" -- cgit v0.12 From b15ae226b92170c6bdb640bf648891cfc177a956 Mon Sep 17 00:00:00 2001 From: ferrieux 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 a4a3d764f5bc4047858e2a14a54d26c55b1cf0c0 Mon Sep 17 00:00:00 2001 From: ferrieux 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 497aa76e901586dee5b41e797c50da9fb9d8f569 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 8d5c986031606a4565659bb82dcbba7ab9ce0186 Mon Sep 17 00:00:00 2001 From: ferrieux 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 1ce040baf210e345e2c8f8a19fe7b8d821274c4b Mon Sep 17 00:00:00 2001 From: dgp 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 0b7aa99ede7838e4390b0c14bcda9485a08d0cf4 Mon Sep 17 00:00:00 2001 From: dkf 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 3db46bb5c46e8ac5171b91b2e137979406d131b6 Mon Sep 17 00:00:00 2001 From: dgp 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 277e045c81735e0509f6c38c56047faa52b5f246 Mon Sep 17 00:00:00 2001 From: dgp 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 aa5429b146778774bfc447513e15c08126877653 Mon Sep 17 00:00:00 2001 From: stwo Date: Mon, 8 Sep 2014 00:37:22 +0000 Subject: Change one '#ifdef' to '#if defined()' for improved consistency within the file, as in checkin [211aa43013]. --- unix/tclUnixCompat.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 0fc51b7..3d2b7b8 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -370,7 +370,7 @@ TclpGetGrNam( #else ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); -#ifdef HAVE_GETGRNAM_R_5 +#if defined(HAVE_GETGRNAM_R_5) struct group *grPtr = NULL; /* -- cgit v0.12 From 07be9a8aa0887809dd6d79d2f079fa1d1558790e Mon Sep 17 00:00:00 2001 From: dgp 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 04d10eb983cb26686f38383404b6b6ef9876f9e1 Mon Sep 17 00:00:00 2001 From: ferrieux 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 e19c2ce585d7fe309059bb96044b08dbfa850a6b Mon Sep 17 00:00:00 2001 From: dkf 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 186cc4a17e82ce9bd90edccc45ab943c63b40c30 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 10 Sep 2014 08:20:46 +0000 Subject: [2486824] Improve error message; not all that upvars is an upvar. --- generic/tclVar.c | 9 ++++----- tests/upvar.test | 11 +++++++---- tests/var.test | 2 +- 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index fda5ff5..a6f6cf4 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3605,9 +3605,8 @@ ObjMakeUpvar( || !HasLocalVars(varFramePtr) || (strstr(TclGetString(myNamePtr), "::") != NULL))) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - TclGetString(myNamePtr), "\": upvar won't create " - "namespace variable that refers to procedure variable", - NULL); + TclGetString(myNamePtr), "\": can't create namespace " + "variable that refers to procedure variable", NULL); return TCL_ERROR; } } @@ -3705,8 +3704,8 @@ TclPtrObjMakeUpvar( */ Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": upvar won't create a scalar variable " - "that looks like an array element", NULL); + myName, "\": can't create a scalar variable that " + "looks like an array element", NULL); return TCL_ERROR; } } diff --git a/tests/upvar.test b/tests/upvar.test index 79c2d53..d18fd3b 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -17,7 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } testConstraint testupvar [llength [info commands testupvar]] - + test upvar-1.1 {reading variables with upvar} { proc p1 {a b} {set c 22; set d 33; p2} proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} @@ -332,7 +332,7 @@ test upvar-8.9 {upvar won't create namespace variable that refers to procedure v unset ::test_ns_1::a } list [catch {MakeLink 1} msg] $msg -} {1 {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}} +} {1 {bad variable name "a": can't create namespace variable that refers to procedure variable}} test upvar-8.10 {upvar will create element alias for new array element} { catch {unset upvarArray} array set upvarArray {} @@ -583,8 +583,11 @@ test upvar-NS-3.3 {CompileWord OBOE} -setup { } -cleanup { rename linenumber {} } -result 1 - - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/var.test b/tests/var.test index 45b7207..c852ca9 100644 --- a/tests/var.test +++ b/tests/var.test @@ -275,7 +275,7 @@ test var-3.11 {MakeUpvar, my var looks like array elem} -body { catch {unset aaaaa} set aaaaa 789789 upvar #0 aaaaa foo(bar) -} -returnCodes 1 -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} +} -returnCodes 1 -result {bad variable name "foo(bar)": can't create a scalar variable that looks like an array element} test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { catch {unset a} -- cgit v0.12 From 7e17c358eb7a149fbec81f4c2e5d1adefcc90bdd Mon Sep 17 00:00:00 2001 From: dgp 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 7a7fd48731220a5a2b1ca9f05e08a193371453b1 Mon Sep 17 00:00:00 2001 From: dkf 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 e4d4eea6f762a3ed154078bff285a3345b69ecd1 Mon Sep 17 00:00:00 2001 From: stwo 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 2eb36b08a9d7f97e811ba6b7aeaddaa7fbfa812d Mon Sep 17 00:00:00 2001 From: stwo Date: Tue, 16 Sep 2014 15:52:44 +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 d11e7d2..ff7791e 100755 --- a/unix/configure +++ b/unix/configure @@ -7576,7 +7576,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 437ce3d..c4e4675 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1499,7 +1499,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 f521b724666bd391377bcc556d0f9103750931b7 Mon Sep 17 00:00:00 2001 From: dkf 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 43921a6b7f362d8ae47b70eb98a7c9b0ff3ee665 Mon Sep 17 00:00:00 2001 From: dgp 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 d9a8b078d1c03a51b8835666ddd27e0e54a2817d Mon Sep 17 00:00:00 2001 From: oehhar 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 2b73bfd8f9c6ba3bd25c0671f33093a0448f41f9 Mon Sep 17 00:00:00 2001 From: ferrieux 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 f987a699e563dd24c0a755d48e0169ac059a5536 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 a21e1b769836e5b589d00985420d87e74c8010e3 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 2 Oct 2014 14:43:10 +0000 Subject: [bc5b790099] Improper calculation of new dstLimit value. New test io-12.7. --- generic/tclIO.c | 5 ++--- tests/io.test | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 3 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 93ac937..3119db5 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5632,12 +5632,11 @@ ReadChars( /* * We read more chars than allowed. Reset limits to * prevent that and try again. Don't forget the extra - * padding of TCL_UTF_MAX - 1 bytes demanded by the + * padding of TCL_UTF_MAX bytes demanded by the * Tcl_ExternalToUtf() call! */ - dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) - + TCL_UTF_MAX - 1 - dst; + dstLimit = Tcl_UtfAtIndex(dst, charsToRead) + TCL_UTF_MAX - dst; statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; diff --git a/tests/io.test b/tests/io.test index 7698cea..b8a5ab4 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1478,6 +1478,39 @@ test io-12.6 {ReadChars: too many chars read} { } close $c } {} +test io-12.7 {ReadChars: too many chars read [bc5b790099]} { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat \uBEEF 10]....\uBEEF] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + 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 + while {![eof $c]} { + read $c 7 + } + close $c +} {} test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] -- cgit v0.12 From b6d046213b7d8a18051b7b0992c6bc1516e4ed2a Mon Sep 17 00:00:00 2001 From: dgp 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 5190862515e3cf2477b403402c70b1c25db282fa Mon Sep 17 00:00:00 2001 From: dgp 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 ae02ceb3de605244211918465b4e4662fe14bc98 Mon Sep 17 00:00:00 2001 From: dgp 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 6c6b3efbe49179c32ae0244e20c9d4096cb51fbe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Oct 2014 07:02:34 +0000 Subject: Fix [59a2e78e54d3361c33b8cd6eef55d384d8abecd7|59a2e78e54] : tclWinTime.c does not compile with MSVC14. Eliminate use of __MINGW32__ macro everywhare, as it is deprecated. --- generic/tcl.h | 2 +- generic/tclAlloc.c | 2 +- win/tclWinPort.h | 8 ++++---- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index af1af58..e915452 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -69,7 +69,7 @@ extern "C" { */ #ifndef __WIN32__ -# if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__)) +# if defined(_WIN32) || defined(WIN32) || defined(__MSVCRT__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__)) # define __WIN32__ # ifndef WIN32 # define WIN32 diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 8d0a2cc..675e1a4 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -31,7 +31,7 @@ * until Tcl uses config.h properly. */ -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__) +#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) typedef unsigned long caddr_t; #endif diff --git a/win/tclWinPort.h b/win/tclWinPort.h index ea6d8f8..b2bf1d7 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -346,17 +346,17 @@ typedef DWORD_PTR * PDWORD_PTR; * EDEADLK as the same value, which confuses Tcl_ErrnoId(). */ -#if defined(_MSC_VER) || defined(__MINGW32__) +#if defined(_MSC_VER) || defined(__MSVCRT__) # define environ _environ # if defined(_MSC_VER) && (_MSC_VER < 1600) # define hypot _hypot # endif # define exception _exception # undef EDEADLOCK -# if defined(__MINGW32__) && !defined(__MSVCRT__) +# if defined(_MSC_VER) && (_MSC_VER >= 1700) # define timezone _timezone # endif -#endif /* _MSC_VER || __MINGW32__ */ +#endif /* _MSC_VER || __MSVCRT__ */ /* * Borland's timezone and environ functions. @@ -425,7 +425,7 @@ typedef DWORD_PTR * PDWORD_PTR; * Msvcrt's putenv() copies the string rather than takes ownership of it. */ -#if defined(_MSC_VER) || defined(__MINGW32__) +#if defined(_MSC_VER) || defined(__MSVCRT__) # define HAVE_PUTENV_THAT_COPIES 1 #endif -- cgit v0.12 From 941cd63bb1b0dbccbdf9827395beda4f1868406f Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 9 Oct 2014 14:52:48 +0000 Subject: [2039178] Remove false claims about TCL_INTERP_DESTROYED flag bit in command traces. --- doc/TraceCmd.3 | 33 ++++++++++----------------------- 1 file changed, 10 insertions(+), 23 deletions(-) diff --git a/doc/TraceCmd.3 b/doc/TraceCmd.3 index b15face..7ff26e4 100644 --- a/doc/TraceCmd.3 +++ b/doc/TraceCmd.3 @@ -84,11 +84,14 @@ operation is being performed on the command. The bit \fBTCL_TRACE_DESTROYED\fR will be set in \fIflags\fR if the trace is about to be destroyed; this information may be useful to \fIproc\fR so that it can clean up its own internal data structures (see the section -\fBTCL_TRACE_DESTROYED\fR below for more details). Lastly, the bit -\fBTCL_INTERP_DESTROYED\fR will be set if the entire interpreter is being -destroyed. When this bit is set, \fIproc\fR must be especially -careful in the things it does (see the section \fBTCL_INTERP_DESTROYED\fR -below). +\fBTCL_TRACE_DESTROYED\fR below for more details). Because the +deletion of commands can take place as part of the deletion of the interp +that contains them, \fIproc\fR must be careful about checking what +the passed in \fIinterp\fR value can be called upon to do. +The routine \fBTcl_InterpDeleted\fR is an important tool for this. +When \fBTcl_InterpDeleted\fR returns 1, \fIproc\fR will not be able +to invoke any scripts in \fIinterp\fR. The function of \fIproc\fR +in that circumstance is limited to the cleanup of its own data structures. .PP \fBTcl_UntraceCommand\fR may be used to remove a trace. If the command specified by \fIinterp\fR, \fIcmdName\fR, and \fIflags\fR has @@ -121,7 +124,8 @@ traces for a given command that have the same \fIproc\fR. .PP During rename traces, the command being renamed is visible with both names simultaneously, and the command still exists during delete -traces (if \fBTCL_INTERP_DESTROYED\fR is not set). However, there is no +traces, unless the interp that contains it is being deleted. +However, there is no mechanism for signaling that an error occurred in a trace procedure, so great care should be taken that errors do not get silently lost. .SH "MULTIPLE TRACES" @@ -140,22 +144,5 @@ rename the command, the last renaming takes precedence. In a delete callback to \fIproc\fR, the \fBTCL_TRACE_DESTROYED\fR bit is set in \fIflags\fR. .\" Perhaps need some more comments here? - DKF -.SH "TCL_INTERP_DESTROYED" -.PP -When an interpreter is destroyed, unset traces are called for -all of its commands. -The \fBTCL_INTERP_DESTROYED\fR bit will be set in the \fIflags\fR -argument passed to the trace procedures. -Trace procedures must be extremely careful in what they do if -the \fBTCL_INTERP_DESTROYED\fR bit is set. -It is not safe for the procedures to invoke any Tcl procedures -on the interpreter, since its state is partially deleted. -All that trace procedures should do under these circumstances is -to clean up and free their own internal data structures. -.SH BUGS -.PP -Tcl does not do any error checking to prevent trace procedures -from misusing the interpreter during traces with \fBTCL_INTERP_DESTROYED\fR -set. .SH KEYWORDS clientData, trace, command -- cgit v0.12 From 7652b23c6d792756ea4ca43dfdf7aed78db58d72 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 10 Oct 2014 15:38:15 +0000 Subject: New test io-53.15 for [ed29c4da21]. --- tests/io.test | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/tests/io.test b/tests/io.test index b8a5ab4..d1faf65 100644 --- a/tests/io.test +++ b/tests/io.test @@ -7610,6 +7610,51 @@ test io-53.11 {Bug 2895565} -setup { removeFile in } -result {40 bytes copied} +test io-53.15 {[ed29c4da21] DoRead: 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 + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 +} -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 # event loops when there is buffered data on the channel. -- cgit v0.12 From 1159aa03c57e16b943f56f65272a590c5b1f0d50 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 10 Oct 2014 18:24:32 +0000 Subject: [ed29c4da21] Don't let BLOCKED state get converted into a channel error. --- generic/tclIO.c | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 3119db5..2fd3792 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8853,21 +8853,39 @@ DoRead( } /* - * If there is not enough data in the buffers to possibly - * complete the read, then go get more. + * Don't read more data if we have what we need. */ - if (bufPtr == NULL || BytesLeft(bufPtr) < bytesToRead) { + while (!bufPtr || /* We got no buffer! OR */ + (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ + (BytesLeft(bufPtr) < bytesToRead) ) ) { + /* Not enough bytes in it + * yet to fill the dst */ + int code; + moreData: - if (GetInput(chanPtr)) { + code = GetInput(chanPtr); + bufPtr = statePtr->inQueueHead; + + assert (bufPtr != NULL); + + if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) { + /* Further reads cannot do any more */ + break; + } + + if (code) { /* Read error */ UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return -1; } - bufPtr = statePtr->inQueueHead; + + assert (IsBufferFull(bufPtr)); } + assert (bufPtr != NULL); + bytesRead = BytesLeft(bufPtr); bytesWritten = bytesToRead; -- cgit v0.12 From 1f83f66e0bc72148d1ea23a44655a8db6992002d Mon Sep 17 00:00:00 2001 From: dgp 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 9235e4c9a7d271d7add0c040d7303d92cdb6589c Mon Sep 17 00:00:00 2001 From: ferrieux 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 4a9b3360d211624e8cbf542a7a65b2f5c6f3b33a Mon Sep 17 00:00:00 2001 From: dgp 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 e059101eedfd4f4901b73f983842b9d1c6e45098 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 10 Oct 2014 19:54:19 +0000 Subject: [bf7135428c] Restore the Tcl_Write() return value logic. --- generic/tclIO.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 2fd3792..d1f22c1 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3484,7 +3484,10 @@ Tcl_Write( if (srcLen < 0) { srcLen = strlen(src); } - return WriteBytes(chanPtr, src, srcLen); + if (WriteBytes(chanPtr, src, srcLen) < 0) { + return -1; + } + return srcLen; } /* -- cgit v0.12 From 61bb4f72ffe5a564476a0d33e12ddc2fa4eea9c1 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 10 Oct 2014 20:02:00 +0000 Subject: backport those tests that can be --- tests/io.test | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) diff --git a/tests/io.test b/tests/io.test index d1faf65..006b403 100644 --- a/tests/io.test +++ b/tests/io.test @@ -7610,6 +7610,68 @@ test io-53.11 {Bug 2895565} -setup { removeFile in } -result {40 bytes copied} +# test io-53.12 not backported. Tests feature only in 8.6+ + +test io-53.13 {TclCopyChannel: read error reporting} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch read} + } + finalize { + return + } + watch {} + read { + error FAIL + } + } + } + set outFile [makeFile {} out] +} -body { + set in [chan create read [namespace which driver]] + chan configure $in -translation binary + set out [open $outFile wb] + chan copy $in $out +} -cleanup { + catch {close $in} + catch {close $out} + removeFile out + rename driver {} +} -result {error reading "*": *} -returnCodes error -match glob +test io-53.14 {TclCopyChannel: write error reporting} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch write} + } + finalize { + return + } + watch {} + write { + error FAIL + } + } + } + set inFile [makeFile {aaa} in] +} -body { + set in [open $inFile rb] + set out [chan create write [namespace which driver]] + chan configure $out -translation binary + chan copy $in $out +} -cleanup { + catch {close $in} + catch {close $out} + removeFile in + rename driver {} +} -result {error writing "*": *} -returnCodes error -match glob test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { proc driver {cmd args} { variable buffer -- cgit v0.12 From 866ad1ea378141901e68603ec8f10f83bf45dac3 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 10 Oct 2014 20:17:12 +0000 Subject: Bump to 8.5.17 --- README | 2 +- generic/tcl.h | 2 +- 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, 8 insertions(+), 8 deletions(-) diff --git a/README b/README index 256174f..425ca16 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.5.16 source distribution. + This is the Tcl 8.5.17 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 e915452..07e48c3 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -61,7 +61,7 @@ extern "C" { #define TCL_RELEASE_SERIAL 16 #define TCL_VERSION "8.5" -#define TCL_PATCH_LEVEL "8.5.16" +#define TCL_PATCH_LEVEL "8.5.17" /* * The following definitions set up the proper options for Windows compilers. diff --git a/library/init.tcl b/library/init.tcl index 61a80a5..5004e0c 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.5.16 +package require -exact Tcl 8.5.17 # 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 ff7791e..1264916 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".16" +TCL_PATCH_LEVEL=".17" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 3228353..22c8985 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".16" +TCL_PATCH_LEVEL=".17" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index bdc6e27..4b6a6a0 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.5.16 +Version: 8.5.17 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index 8e33eb3..dc24431 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".16" +TCL_PATCH_LEVEL=".17" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 diff --git a/win/configure.in b/win/configure.in index aa42036..14d9b0f 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".16" +TCL_PATCH_LEVEL=".17" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 -- cgit v0.12 From ceff856085045650b5b10e2d2fea1355ba78e4c4 Mon Sep 17 00:00:00 2001 From: dgp 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 3b9d194ccde9669b9b28b6be675f09f83ac9b891 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 13 Oct 2014 17:15:55 +0000 Subject: update changes file --- changes | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/changes b/changes index 4b5ba55..4bfe0e4 100644 --- a/changes +++ b/changes @@ -7894,3 +7894,13 @@ of Tcl_Channel (porter) 2014-08-12 tzdata updated to Olson's tzdata2014f (kenny) --- Released 8.5.16, August 25, 2014 --- http://core.tcl.tk/tcl/ for details + +2014-10-02 (bug)[bc5b79] Hang in some [read]s of limited size (rogers,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.5.17, October 25, 2014 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From 73df1e04588ba22154d42e7eedee8f709d3e26fa Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 13 Oct 2014 17:34:12 +0000 Subject: missed a bump --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index 07e48c3..98cd577 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -58,7 +58,7 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 5 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 16 +#define TCL_RELEASE_SERIAL 17 #define TCL_VERSION "8.5" #define TCL_PATCH_LEVEL "8.5.17" -- cgit v0.12 From f270cc876db91a80fda35fd57e55859d3a9331f6 Mon Sep 17 00:00:00 2001 From: dgp 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 a9606871f5ddb7d6a8cd69f3fa0c41fe8b3c0396 Mon Sep 17 00:00:00 2001 From: oehhar 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 65acf25995e78db3c34b4cfd4998caf4edd4a5d8 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 17 Oct 2014 15:20:34 +0000 Subject: [10dc6daa37] [gets] on a non-blocking channel must take care so that 1) At least one call to the channel driver input proc gets made. Failure to do this locks up the channel - catastrophic FAIL. 2) After any driver call reports BLOCKED, don't call again. This is less serious, but FAILs to respect the non-blocking setting. Code corrections and tests included, to restore 8.5.15 compat. --- generic/tclIO.c | 6 +++++ tests/io.test | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 74 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index d1f22c1..e786946 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4042,6 +4042,7 @@ Tcl_GetsObj( eof = NULL; inEofChar = statePtr->inEofChar; + ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { if (dst >= dstEnd) { if (FilterInputBytes(chanPtr, &gs) != 0) { @@ -4211,6 +4212,10 @@ Tcl_GetsObj( } goto gotEOL; } + if (GotFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_NONBLOCKING) + == (CHANNEL_BLOCKED|CHANNEL_NONBLOCKING)) { + goto restore; + } dst = dstEnd; } @@ -4386,6 +4391,7 @@ TclGetsObjBinary( /* Only handle TCL_TRANSLATE_LF and TCL_TRANSLATE_CR */ eolChar = (statePtr->inputTranslation == TCL_TRANSLATE_LF) ? '\n' : '\r'; + ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { /* * Subtract the number of bytes that were removed from channel diff --git a/tests/io.test b/tests/io.test index 006b403..0d9468d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -4299,6 +4299,74 @@ test io-33.10 {Tcl_Gets, exercising double buffering} { close $f set y } 300 +test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -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 { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 3} {set n 3} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -translation binary -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result {{} {} {} .......} +test io-33.12 {TclGetsObjBinary, [10dc6daa37]} -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 { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 3} {set n 3} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result {{} {} {} .......} # Test Tcl_Seek and Tcl_Tell. -- cgit v0.12 From 5af269e0994dcffae3ea5df62337b8c7aae7722c Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 18 Oct 2014 20:11:36 +0000 Subject: update changes --- changes | 2 ++ 1 file changed, 2 insertions(+) diff --git a/changes b/changes index 4bfe0e4..6a617fa 100644 --- a/changes +++ b/changes @@ -7903,4 +7903,6 @@ of Tcl_Channel (porter) 2014-10-10 (bug)[bf7135] regression in Tcl_Write() interface (porter) +2014-10-18 (bug)[10dc6d] fix [gets] on non-blocking channels (fassel,porter) + --- Released 8.5.17, October 25, 2014 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From c9267414a3fbeea5ffd03e6b3c60a07edb013a78 Mon Sep 17 00:00:00 2001 From: dgp 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 aa669c0d1cbe8d3fd7e7ce23cca9a9bfa3807631 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 26 Oct 2014 07:51:22 +0000 Subject: Support for Windows 10 --- win/tclsh.exe.manifest.in | 2 ++ 1 file changed, 2 insertions(+) diff --git a/win/tclsh.exe.manifest.in b/win/tclsh.exe.manifest.in index b7c4381..8b06fce 100644 --- a/win/tclsh.exe.manifest.in +++ b/win/tclsh.exe.manifest.in @@ -20,6 +20,8 @@ + + -- cgit v0.12 From 7ab8a9b2efc85997d0a6f576c20a69d272bd98ff Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 Oct 2014 20:10:32 +0000 Subject: Work in progress restoring ability to [read] after [eof] and get non-empty strings back in those cases where the channel has them to offer. Also working through all the implications of this possibility on Tcl's more exotic channel features, like stacking. --- generic/tclIO.c | 88 ++++++++++++++++++++++++++++++++++++++++++------------- generic/tclIOGT.c | 20 ++++++++----- 2 files changed, 79 insertions(+), 29 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 0122ec9..c55c118 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4414,6 +4414,17 @@ TclGetsObjBinary( if (bufPtr == NULL) { goto restore; } + } else { + /* + * There's something already in the buffer. If + * CHANNEL_STICKY_EOF is set we know that something begins + * with the eofchar. Otherwise, if CHANNEL_EOF is set, we + * know some earlier inputproc call returned zero bytes when + * we were trying to get more bytes to put in the buffer. + * which means..... ???? Place to probe with tests. + */ + assert (GotFlag(statePtr, CHANNEL_STICKY_EOF) + || !GotFlag(statePtr, CHANNEL_EOF) ); } dst = (unsigned char *) RemovePoint(bufPtr); @@ -4694,6 +4705,9 @@ FilterInputBytes( gsPtr->rawRead = 0; return -1; } + } else { + assert( GotFlag(statePtr, CHANNEL_STICKY_EOF) + || !GotFlag(statePtr, CHANNEL_EOF) ); } /* @@ -5018,6 +5032,7 @@ Tcl_ReadRaw( /* State info for channel */ int copied = 0; + assert(bytesToRead > 0); if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) { return -1; } @@ -5049,8 +5064,19 @@ Tcl_ReadRaw( } } - /* Go to the driver if more data needed. */ + /* + * Go to the driver only if we got nothing from pushback. + * Have to do it this way to avoid EOF mis-timings when we + * consider the ability that EOF may not be a permanent + * condition in the driver, and in that case we have to + * synchronize. + */ + + if (copied) { + return copied; + } + /* This test not needed. */ if (bytesToRead > 0) { int nread = ChanRead(chanPtr, readBuf, bytesToRead); @@ -5073,12 +5099,10 @@ Tcl_ReadRaw( if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) { copied = -1; } - } else if (copied > 0) { + } else { /* - * nread == 0. Driver is at EOF, but if copied>0 bytes - * from pushback, then we should not signal it yet. + * nread == 0. Driver is at EOF. Let that state filter up. */ - ResetFlag(statePtr, CHANNEL_EOF); } } return copied; @@ -6120,18 +6144,39 @@ GetInput( } /* - * For a channel at EOF do not bother allocating buffers; there's - * nothing more to read. Avoid calling the driver inputproc in - * case some of them do not react well to additional calls after - * they've reported an eof state.. - * TODO: Candidate for a can't happen panic. + * Strangely named "STICKY_EOF" really means we've seen the + * eofchar for this channel, and nothing since has reset it. + * (changed the eofchar, [seek]ed to a new offset, etc.) So, + * we know we're still poised to read that eofchar again, and + * there's no need to actually do it. */ - if (GotFlag(statePtr, CHANNEL_EOF)) { + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + assert(statePtr->inEofChar); + assert(statePtr->inQueueHead); + assert(RemovePoint(statePtr->inQueueHead)[0] == statePtr->inEofChar); return 0; } /* + * WARNING: There was once a comment here claiming that it was + * a bad idea to make another call to the inputproc of a channel + * driver when EOF has already been detected on the channel. Through + * much of Tcl's history, this warning was then completely negated + * by having all (most?) read paths clear the EOF setting before + * reaching here. So we had a guard that was never triggered. + * + * Don't be tempted to restore the guard. Even if EOF is set on + * the channel, continue through and call the inputproc again. This + * is the way to enable the ability to [read] again beyond the EOF, + * which seems a strange thing to do, but for which use cases exist + * [Tcl Bug 5adc350683] and which may even be essential for channels + * representing things like ttys or other devices where the stream + * might take the logical form of a series of 'files' separated by + * an EOF condition. + */ + + /* * First check for more buffers in the pushback area of the topmost * channel in the stack and use them. They can be the result of a * transformation which went away without reading all the information @@ -8848,16 +8893,6 @@ DoRead( ChannelBuffer *bufPtr = statePtr->inQueueHead; /* - * When there's no buffered data to read, and we're at EOF, - * escape to the caller. - */ - - if (GotFlag(statePtr, CHANNEL_EOF) - && (bufPtr == NULL || IsBufferEmpty(bufPtr))) { - break; - } - - /* * Don't read more data if we have what we need. */ @@ -8969,12 +9004,23 @@ DoRead( statePtr->inQueueTail = NULL; } RecycleBuffer(statePtr, bufPtr, 0); + bufPtr = statePtr->inQueueHead; } if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED) == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) { break; } + + /* + * When there's no buffered data to read, and we're at EOF, + * escape to the caller. + */ + + if (GotFlag(statePtr, CHANNEL_EOF) + && (bufPtr == NULL || IsBufferEmpty(bufPtr))) { + break; + } } if (bytesToRead == 0) { ResetFlag(statePtr, CHANNEL_BLOCKED); diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index fe0a880..a78a5b4 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -677,6 +677,18 @@ TransformInputProc( break; } + if (dataPtr->readIsFlushed) { + /* + * Already saw EOF from downChan; don't ask again. + * NOTE: Could move this up to avoid the last maxRead + * execution. Believe this would still be correct behavior, + * but the test suite tests the whole command callback + * sequence, so leave it unchanged for now. + */ + + break; + } + /* * Get bytes from the underlying channel. */ @@ -712,14 +724,6 @@ TransformInputProc( * on the down channel. */ - if (dataPtr->readIsFlushed) { - /* - * Already flushed, nothing to do anymore. - */ - - break; - } - dataPtr->readIsFlushed = 1; ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF, P_PRESERVE); -- cgit v0.12 From 75e9bc701fe237f31e8d1467070fadbcc5457a32 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 29 Oct 2014 14:54:11 +0000 Subject: Base test for [5adc350683]. --- tests/io.test | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/tests/io.test b/tests/io.test index f6690ad..d533957 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8399,6 +8399,26 @@ test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} {} { list $code [string map [list $f @@] $msg] } {1 {can not find channel named "@@"}} +test io-73.3 {[5adc350683] [gets] after EOF} -setup { + set fn [makeFile {} io-73.3] + set rfd [open $fn r] + set wfd [open $fn a] + chan configure $wfd -buffering line + read $rfd +} -body { + set result [eof $rfd] + puts $wfd "more data" + lappend result [eof $rfd] + lappend result [gets $rfd] + lappend result [eof $rfd] + lappend result [gets $rfd] + lappend result [eof $rfd] +} -cleanup { + close $wfd + close $rfd + removeFile io-73.3 +} -result {1 1 {more data} 0 {} 1} + # ### ### ### ######### ######### ######### # cleanup -- cgit v0.12 From f6161cafab22785e5a346b26bd0ef59cdb950c57 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 31 Oct 2014 09:59:36 +0000 Subject: When translating a reserved devicename to native pathname, strip ':' postfix. Possible fix for [dcc03414f5], but anyway a good idea. --- win/tclWinFile.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 9bf63b1..163050e 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -3203,7 +3203,10 @@ TclNativeCreateNativeRep( Tcl_WinUtfToTChar(str, len, &ds); if (tclWinProcs->useWide) { WCHAR *wp = (WCHAR *) Tcl_DStringValue(&ds); - len = Tcl_DStringLength(&ds)>>1; + /* For a reserved device, strip a possible postfix ':' */ + len = WinIsReserved(str); + /* For normal devices */ + if (len == 0) len = Tcl_DStringLength(&ds)>>1; /* ** If path starts with "//?/" or "\\?\" (extended path), translate ** any slashes to backslashes but accept the '?' as being valid. -- cgit v0.12 From 384950b6d12f0e3d0da23ed08707b41eb609c9cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 31 Oct 2014 10:57:25 +0000 Subject: Extend WinIsReserved() to recognize COM[5-9]: as valid com ports as well. --- win/tclWinFile.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 163050e..7487022 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1225,9 +1225,9 @@ WinIsReserved( if ((path[0] == 'c' || path[0] == 'C') && (path[1] == 'o' || path[1] == 'O')) { if ((path[2] == 'm' || path[2] == 'M') - && path[3] >= '1' && path[3] <= '4') { + && path[3] >= '1' && path[3] <= '9') { /* - * May have match for 'com[1-4]:?', which is a serial port. + * May have match for 'com[1-9]:?', which is a serial port. */ if (path[4] == '\0') { -- cgit v0.12 From 9d91e28e770e770f99f3c3115ab9e86e9d481a2d Mon Sep 17 00:00:00 2001 From: dgp 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 746cb2938e7c4bf900a55899aa1445ece67d52ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 3 Nov 2014 10:14:48 +0000 Subject: Better errormessage when file path contains invalid characters. See: [03414f517b7a74]. --- win/tclWinChan.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 6d480a8..a271919 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -840,6 +840,11 @@ TclpOpenFileChannel( nativeName = (TCHAR*) Tcl_FSGetNativePath(pathPtr); if (nativeName == NULL) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", + TclGetString(pathPtr), "\": filename is invalid on this platform", + NULL); + } return NULL; } -- cgit v0.12 From bce5edef8b197d622f6f22b25021afd987743698 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 3 Nov 2014 12:44:55 +0000 Subject: Add test-case for previous commit, which shows that when trying to open a filename with invalid characters gives the right error-message. (same bug existed on UNIX too, which is now fixed) --- tests/fileSystem.test | 3 +++ unix/tclUnixChan.c | 5 +++++ 2 files changed, 8 insertions(+) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 161ebc3..c255b1e 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -708,6 +708,9 @@ test filesystem-6.32 {empty file name} { test filesystem-6.33 {empty file name} { list [catch {file writable ""} msg] $msg } {0 0} +test filesystem-6.34 {file name with (invalid) nul character} { + list [catch "open foo\x00" msg] $msg +} [list 1 "couldn't open \"foo\x00\": filename is invalid on this platform"] # Make sure the testfilesystem hasn't been registered. if {[testConstraint testfilesystem]} { diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 1d60340..89c9a27 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1647,6 +1647,11 @@ TclpOpenFileChannel( native = Tcl_FSGetNativePath(pathPtr); if (native == NULL) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", + TclGetString(pathPtr), "\": filename is invalid on this platform", + NULL); + } return NULL; } -- cgit v0.12 From c40bcd39bfbe1d61ef75fd3cc9a6604b6cd20193 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 3 Nov 2014 20:39:25 +0000 Subject: [5adc350683] Reworked the management of the EOF states to re-enable the ability to read beyond EOF. Plenty of assert()s to keep thing from going off track again. --- generic/tclIO.c | 182 +++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 139 insertions(+), 43 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index c55c118..b3af1f5 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3977,6 +3977,21 @@ Tcl_GetsObj( } /* + * If we're sitting ready to read the eofchar, there's no need to + * do it. + */ + + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + SetFlag(statePtr, CHANNEL_EOF); + assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); + assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + + /* TODO: Do we need this? */ + UpdateInterest(chanPtr); + return -1; + } + + /* * A binary version of Tcl_GetsObj. This could also handle encodings that * are ascii-7 pure (iso8859, utf-8, ...) with a final encoding conversion * done on objPtr. @@ -4194,6 +4209,7 @@ Tcl_GetsObj( dstEnd = eof; SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } if (GotFlag(statePtr, CHANNEL_EOF)) { skip = 0; @@ -4307,6 +4323,13 @@ Tcl_GetsObj( */ done: + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); + /* * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. @@ -4330,6 +4353,11 @@ Tcl_GetsObj( * end-of-line or end-of-file has been seen. Bytes read from the input * channel return as a ByteArray obj. * + * WARNING! The notion of "binary" used here is different from + * notions of "binary" used in other places. In particular, this + * "binary" routine may be called when an -eofchar is set on the + * channel. + * * Results: * Number of characters accumulated in the object or -1 if error, * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error @@ -4416,15 +4444,15 @@ TclGetsObjBinary( } } else { /* - * There's something already in the buffer. If - * CHANNEL_STICKY_EOF is set we know that something begins - * with the eofchar. Otherwise, if CHANNEL_EOF is set, we - * know some earlier inputproc call returned zero bytes when - * we were trying to get more bytes to put in the buffer. - * which means..... ???? Place to probe with tests. - */ - assert (GotFlag(statePtr, CHANNEL_STICKY_EOF) - || !GotFlag(statePtr, CHANNEL_EOF) ); + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. + * A new CHANNEL_STICKY_EOF set in this routine leads to + * return before coming back here. When we are not dealing + * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an + * empty buffer. Here the buffer is non-empty so we know + * we're a non-EOF */ + + assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); + assert ( !GotFlag(statePtr, CHANNEL_EOF) ); } dst = (unsigned char *) RemovePoint(bufPtr); @@ -4466,6 +4494,7 @@ TclGetsObjBinary( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } if (GotFlag(statePtr, CHANNEL_EOF)) { skip = 0; @@ -4575,6 +4604,11 @@ TclGetsObjBinary( */ done: + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; @@ -4706,8 +4740,16 @@ FilterInputBytes( return -1; } } else { - assert( GotFlag(statePtr, CHANNEL_STICKY_EOF) - || !GotFlag(statePtr, CHANNEL_EOF) ); + /* + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. + * A new CHANNEL_STICKY_EOF set in this routine leads to + * return before coming back here. When we are not dealing + * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an + * empty buffer. Here the buffer is non-empty so we know + * we're a non-EOF */ + + assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); + assert ( !GotFlag(statePtr, CHANNEL_EOF) ); } /* @@ -5201,19 +5243,11 @@ DoReadChars( ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int factor, copied, copiedNow, result; - Tcl_Encoding encoding; + int copied, copiedNow, result; + Tcl_Encoding encoding = statePtr->encoding; int binaryMode; #define UTF_EXPANSION_FACTOR 1024 - - /* - * This operation should occur at the top of a channel stack. - */ - - chanPtr = statePtr->topChanPtr; - encoding = statePtr->encoding; - factor = UTF_EXPANSION_FACTOR; - TclChannelPreserve((Tcl_Channel)chanPtr); + int factor = UTF_EXPANSION_FACTOR; binaryMode = (encoding == NULL) && (statePtr->inputTranslation == TCL_TRANSLATE_LF) @@ -5237,6 +5271,36 @@ DoReadChars( } } + /* + * Early out when next read will see eofchar. + * + * NOTE: See DoRead for argument that it's a bug (one we're keeping) + * to have this escape before the one for zero-char read request. + */ + + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + SetFlag(statePtr, CHANNEL_EOF); + assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); + assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + + UpdateInterest(chanPtr); + return 0; + } + + /* Special handling for zero-char read request. */ + if (toRead == 0) { + ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); + UpdateInterest(chanPtr); + return 0; + } + + /* + * This operation should occur at the top of a channel stack. + */ + + chanPtr = statePtr->topChanPtr; + TclChannelPreserve((Tcl_Channel)chanPtr); + /* Must clear the BLOCKED flag here since we check before reading */ ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); for (copied = 0; (unsigned) toRead > 0; ) { @@ -5314,6 +5378,11 @@ DoReadChars( * Update the notifier state so we don't block while there is still data * in the buffers. */ + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return copied; @@ -5922,7 +5991,7 @@ TranslateInputEOL( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; - ResetFlag(statePtr, INPUT_SAW_CR); + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } } @@ -6132,6 +6201,14 @@ GetInput( ChannelState *statePtr = chanPtr->state; /* State info for channel */ + /* + * Verify that all callers know better than to call us when + * it's recorded that the next char waiting to be read is the + * eofchar. + */ + + assert( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); + /* * Prevent reading from a dead channel -- a channel that has been closed * but not yet deallocated, which can happen if the exit handler for @@ -6143,21 +6220,6 @@ GetInput( return EINVAL; } - /* - * Strangely named "STICKY_EOF" really means we've seen the - * eofchar for this channel, and nothing since has reset it. - * (changed the eofchar, [seek]ed to a new offset, etc.) So, - * we know we're still poised to read that eofchar again, and - * there's no need to actually do it. - */ - - if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { - assert(statePtr->inEofChar); - assert(statePtr->inQueueHead); - assert(RemovePoint(statePtr->inQueueHead)[0] == statePtr->inEofChar); - return 0; - } - /* * WARNING: There was once a comment here claiming that it was * a bad idea to make another call to the inputproc of a channel @@ -6185,6 +6247,7 @@ GetInput( if (chanPtr->inQueueHead != NULL) { + /* TODO: Tests to cover this. */ assert(statePtr->inQueueHead == NULL); statePtr->inQueueHead = chanPtr->inQueueHead; @@ -6215,6 +6278,7 @@ GetInput( * Check the actual buffersize against the requested buffersize. * Saved buffers of the wrong size are squashed. This is done * to honor dynamic changes of the buffersize made by the user. + * TODO: Tests to cover this. */ if ((bufPtr != NULL) @@ -6758,9 +6822,7 @@ Tcl_Eof( ChannelState *statePtr = ((Channel *) chan)->state; /* State of real channel structure. */ - return (GotFlag(statePtr, CHANNEL_STICKY_EOF) || - (GotFlag(statePtr, CHANNEL_EOF) && - (Tcl_InputBuffered(chan) == 0))) ? 1 : 0; + return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; } /* @@ -8882,6 +8944,36 @@ DoRead( ChannelState *statePtr = chanPtr->state; char *p = dst; + assert (bytesToRead >= 0); + + /* + * Early out when we know a read will get the eofchar. + * + * NOTE: This seems to be a bug. The special handling for + * a zero-char read request ought to come first. As coded + * the EOF due to eofchar has distinguishing behavior from + * the EOF due to reported EOF on the underlying device, and + * that seems undesirable. However recent history indicates + * that new inconsistent behavior in a patchlevel has problems + * too. Keep on keeping on for now. + */ + + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + SetFlag(statePtr, CHANNEL_EOF); + assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); + assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + + UpdateInterest(chanPtr); + return 0; + } + + /* Special handling for zero-char read request. */ + if (bytesToRead == 0) { + ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); + UpdateInterest(chanPtr); + return 0; + } + TclChannelPreserve((Tcl_Channel)chanPtr); while (bytesToRead) { /* @@ -8952,8 +9044,7 @@ DoRead( * 1) We're @EOF because we saw eof char. */ - if (statePtr->inEofChar - && RemovePoint(bufPtr)[0] == statePtr->inEofChar) { + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { UpdateInterest(chanPtr); break; } @@ -9026,6 +9117,11 @@ DoRead( ResetFlag(statePtr, CHANNEL_BLOCKED); } + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); TclChannelRelease((Tcl_Channel)chanPtr); return (int)(p - dst); } -- cgit v0.12 From 77d8108158b1e45e8dc31209eccbe00787a73fb2 Mon Sep 17 00:00:00 2001 From: dgp 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 6329a786eedb7e86de0fb843dfa3c3a1faac5986 Mon Sep 17 00:00:00 2001 From: dgp 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 db0b450fcc8673487056f6292838cc14ffa54c5e Mon Sep 17 00:00:00 2001 From: dgp 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 836a10622561a68136fe41a106892b55aafb9fc3 Mon Sep 17 00:00:00 2001 From: dgp 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 7cc4c83aed245ab7ec48a2d037c43b8b59cfdddb Mon Sep 17 00:00:00 2001 From: dgp 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 06fa92e9a424d57ed4c9458474f5f8a7b42cc654 Mon Sep 17 00:00:00 2001 From: dgp 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 a8c6a73058b823dbb1ea5e3832d016284820400e Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Nov 2014 15:06:52 +0000 Subject: New test iogt-7.0 demos bug in [testchannel transform]. --- tests/iogt.test | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/tests/iogt.test b/tests/iogt.test index 5fe3dc2..1a18afc 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -996,6 +996,48 @@ test iogt-6.1 {Push back and up} {testchannel knownBug} { set res } {xxxghi} +# 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 + 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 + } + } + } + +test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body { + set chan [chan create read [namespace which driver]] + identity -attach $chan + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} # cleanup foreach file [list dummy dummyout __echo_srv__.tcl] { -- cgit v0.12 From 4ec8e3c11c2a7fdc1fd9efce21a8e6d92ce8a0e5 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Nov 2014 15:49:30 +0000 Subject: fix failing test --- generic/tclIOGT.c | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index a78a5b4..7ba2f2a 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -187,6 +187,7 @@ struct TransformChannelData { Tcl_Channel self; /* Our own Channel handle. */ int readIsFlushed; /* Flag to note whether in.flushProc was * called or not. */ + int eofPending; /* Flag: EOF seen down, not raised up */ int flags; /* Currently CHANNEL_ASYNC or zero. */ int watchMask; /* Current watch/event/interest mask. */ int mode; /* Mode of parent channel, OR'ed combination @@ -292,6 +293,7 @@ TclChannelTransform( Tcl_DStringInit(&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; dataPtr->flags = 0; if (ds.string[0] == '0') { dataPtr->flags |= CHANNEL_ASYNC; @@ -624,7 +626,7 @@ TransformInputProc( if (toRead == 0 || dataPtr->self == NULL) { /* - * Catch a no-op. + * Catch a no-op. TODO: Is this a panic()? */ return 0; } @@ -676,8 +678,7 @@ TransformInputProc( if (toRead <= 0) { break; } - - if (dataPtr->readIsFlushed) { + if (dataPtr->eofPending) { /* * Already saw EOF from downChan; don't ask again. * NOTE: Could move this up to avoid the last maxRead @@ -724,6 +725,7 @@ TransformInputProc( * on the down channel. */ + dataPtr->eofPending = 1; dataPtr->readIsFlushed = 1; ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF, P_PRESERVE); @@ -751,8 +753,11 @@ TransformInputProc( break; } } /* while toRead > 0 */ - ReleaseData(dataPtr); + if (gotBytes == 0) { + dataPtr->eofPending = 0; + } + ReleaseData(dataPtr); return gotBytes; } @@ -863,6 +868,7 @@ TransformSeekProc( P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; } ReleaseData(dataPtr); @@ -936,6 +942,7 @@ TransformWideSeekProc( P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; } ReleaseData(dataPtr); -- cgit v0.12 From 4cb80cd4e64044f5891b073788734efd753e5100 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Nov 2014 16:12:26 +0000 Subject: Also test transfroms that delay. --- tests/iogt.test | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/tests/iogt.test b/tests/iogt.test index 1a18afc..89e62d4 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -1039,6 +1039,36 @@ test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body { close $chan } -result {0 ..... 1 {} 0 ..... 1} +proc delay {op data} { + variable store + switch -- $op { + create/write - create/read - + delete/write - delete/read - + flush/write - write - + clear_read {;#ignore} + flush/read - + read { + if {![info exists store]} {set store {}} + set reply $store + set store $data + return $reply + } + query/maxRead {return -1} + } +} + +test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body { + set chan [chan create read [namespace which driver]] + testchannel transform $chan -command [namespace code delay] + 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 delay {} +rename driver {} + # cleanup foreach file [list dummy dummyout __echo_srv__.tcl] { removeFile $file -- cgit v0.12 From f033a745db5e733d99ebc0a7895320435de1bd82 Mon Sep 17 00:00:00 2001 From: dgp 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 4ec954d30638d7601c2f884c6a70f30ebab5ac11 Mon Sep 17 00:00:00 2001 From: dgp 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 e783e0d809bd84c85d8cf7914540f409b503df4b Mon Sep 17 00:00:00 2001 From: dgp 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 3e48a2fd72b0b60f4e8f3d59eccd73a3c39d8d9d Mon Sep 17 00:00:00 2001 From: dgp 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 69d586c18ca336c0b7eafea4bdebcf7c01b769ce Mon Sep 17 00:00:00 2001 From: dkf 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 d18e6da3e471bdaecc24da3e4dfb28620b880daa Mon Sep 17 00:00:00 2001 From: dgp 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 b7b8194d8178e6ed5b12f5b2ea3eef30bb132c99 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Nov 2014 12:29:04 +0000 Subject: Improve documentation on the use of com ports (remove references to Windows 95, deprecate the use of postfix ':'). Allow lpt[5-9] just as com[5-9], and make sure that path normalization works as expected for ports > 4. --- doc/open.n | 60 +++++++++++---------------------------------------- generic/tclFileName.c | 8 +++---- tests/winFCmd.test | 13 +++++++---- win/tclWinFile.c | 4 ++-- 4 files changed, 28 insertions(+), 57 deletions(-) diff --git a/doc/open.n b/doc/open.n index b888126..7216607 100644 --- a/doc/open.n +++ b/doc/open.n @@ -331,61 +331,27 @@ may cause this error. A BREAK condition has been detected by your UART (see above). .SH "PORTABILITY ISSUES" .TP -\fBWindows \fR(all versions) +\fBWindows \fR Valid values for \fIfileName\fR to open a serial port are of the form -\fBcom\fIX\fB:\fR, where \fIX\fR is a number, generally from 1 to 4. -This notation only works for serial ports from 1 to 9, if the system -happens to have more than four. An attempt to open a serial port that +\fBcom\fIX\fB\fR, where \fIX\fR is a number, generally from 1 to 9. +A legacy form accepted as well is \fBcom\fIX\fB:\fR. This notation only +works for serial ports from 1 to 9. An attempt to open a serial port that does not exist or has a number greater than 9 will fail. An alternate -form of opening serial ports is to use the filename \fB\e\e.\ecomX\fR, -where X is any number that corresponds to a serial port; please note -that this method is considerably slower on Windows 95 and Windows 98. -.TP -\fBWindows NT\fR +form of opening serial ports is to use the filename \fB//./comX\fR, +where X is any number that corresponds to a serial port. +.RS +.PP When running Tcl interactively, there may be some strange interactions between the real console, if one is present, and a command pipeline that uses standard input or output. If a command pipeline is opened for reading, some of the lines entered at the console will be sent to the command pipeline and some will be sent to the Tcl evaluator. If a command pipeline is opened for writing, keystrokes entered into the console are not visible until the -pipe is closed. This behavior occurs whether the command pipeline is -executing 16-bit or 32-bit applications. These problems only occur because -both Tcl and the child application are competing for the console at -the same time. If the command pipeline is started from a script, so that Tcl -is not accessing the console, or if the command pipeline does not use -standard input or output, but is redirected from or to a file, then the -above problems do not occur. -.TP -\fBWindows 95\fR -A command pipeline that executes a 16-bit DOS application cannot be opened -for both reading and writing, since 16-bit DOS applications that receive -standard input from a pipe and send standard output to a pipe run -synchronously. Command pipelines that do not execute 16-bit DOS -applications run asynchronously and can be opened for both reading and -writing. -.RS -.PP -When running Tcl interactively, there may be some strange interactions -between the real console, if one is present, and a command pipeline that uses -standard input or output. If a command pipeline is opened for reading from -a 32-bit application, some of the keystrokes entered at the console will be -sent to the command pipeline and some will be sent to the Tcl evaluator. If -a command pipeline is opened for writing to a 32-bit application, no output -is visible on the console until the pipe is closed. These problems only -occur because both Tcl and the child application are competing for the -console at the same time. If the command pipeline is started from a script, -so that Tcl is not accessing the console, or if the command pipeline does -not use standard input or output, but is redirected from or to a file, then -the above problems do not occur. -.PP -Whether or not Tcl is running interactively, if a command pipeline is opened -for reading from a 16-bit DOS application, the call to \fBopen\fR will not -return until end-of-file has been received from the command pipeline's -standard output. If a command pipeline is opened for writing to a 16-bit DOS -application, no data will be sent to the command pipeline's standard output -until the pipe is actually closed. This problem occurs because 16-bit DOS -applications are run synchronously, as described above. -.RE +pipe is closed. These problems only occur because both Tcl and the child +application are competing for the console at the same time. If the command +pipeline is started from a script, so that Tcl is not accessing the console, +or if the command pipeline does not use standard input or output, but is +redirected from or to a file, then the above problems do not occur. .TP \fBUnix\fR\0\0\0\0\0\0\0 Valid values for \fIfileName\fR to open a serial port are generally of the diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 07757d9..a8360fc 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -225,9 +225,9 @@ ExtractWinRoot( if ((path[0] == 'c' || path[0] == 'C') && (path[1] == 'o' || path[1] == 'O')) { if ((path[2] == 'm' || path[2] == 'M') - && path[3] >= '1' && path[3] <= '4') { + && path[3] >= '1' && path[3] <= '9') { /* - * May have match for 'com[1-4]:?', which is a serial port. + * May have match for 'com[1-9]:?', which is a serial port. */ if (path[4] == '\0') { @@ -247,9 +247,9 @@ ExtractWinRoot( } else if ((path[0] == 'l' || path[0] == 'L') && (path[1] == 'p' || path[1] == 'P') && (path[2] == 't' || path[2] == 'T')) { - if (path[3] >= '1' && path[3] <= '3') { + if (path[3] >= '1' && path[3] <= '9') { /* - * May have match for 'lpt[1-3]:?' + * May have match for 'lpt[1-9]:?' */ if (path[4] == '\0') { diff --git a/tests/winFCmd.test b/tests/winFCmd.test index ef1c4e7..f0cb406 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -1110,16 +1110,16 @@ test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body { } -result "absolute" test winFCmd-18.1.3 {Windows reserved path names} -constraints win -body { - file pathtype com5 -} -result "relative" + file pathtype com9 +} -result "absolute" test winFCmd-18.1.4 {Windows reserved path names} -constraints win -body { file pathtype lpt3 } -result "absolute" test winFCmd-18.1.5 {Windows reserved path names} -constraints win -body { - file pathtype lpt4 -} -result "relative" + file pathtype lpt9 +} -result "absolute" test winFCmd-18.1.6 {Windows reserved path names} -constraints win -body { file pathtype nul @@ -1238,6 +1238,11 @@ test winFCmd-19.8 {Windows extended path names} -constraints nt -setup { catch {file delete $tmpfile} } -result [list 0 {} [list "tcl[pid].tmp "]] +test winFCmd-19.9 {Windows devices path names} -constraints nt -body { + file normalize //./com1 +} -result //./com1 + + # This block of code used to occur after the "return" call, so I'm # commenting it out and assuming that this code is still under construction. #foreach source {tef ted tnf tnd "" nul com1} { diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 7487022..76cd561 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1246,9 +1246,9 @@ WinIsReserved( } else if ((path[0] == 'l' || path[0] == 'L') && (path[1] == 'p' || path[1] == 'P') && (path[2] == 't' || path[2] == 'T')) { - if (path[3] >= '1' && path[3] <= '3') { + if (path[3] >= '1' && path[3] <= '9') { /* - * May have match for 'lpt[1-3]:?' + * May have match for 'lpt[1-9]:?' */ if (path[4] == '\0') { -- cgit v0.12 From c2a87a1640d623b273f5d410119278db08c159b3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" 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 c297897b8f3cef07ec0a8b86f7bf56322f8e65dc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" 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 598b0dc3f2ad75fcacdec6ed563219816b1db0ef Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" 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 51acb4e23f6c50b6cd0029ab6503034ce76bea05 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 24 Nov 2014 03:00:03 +0000 Subject: [e087812465] Trim back operatorStrings array to just the entries that are needed. Trims away the part of the array that was out of sync with the opcodes. --- generic/tclExecute.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c4f9836..b9415e5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -75,9 +75,7 @@ int tclTraceExec = 0; static const char *const operatorStrings[] = { "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", - "+", "-", "*", "/", "%", "+", "-", "~", "!", - "BUILTIN FUNCTION", "FUNCTION", - "", "", "", "", "", "", "", "", "eq", "ne" + "+", "-", "*", "/", "%", "+", "-", "~", "!" }; /* @@ -7714,7 +7712,7 @@ IllegalExprOperandType( if (opcode == INST_EXPON) { operator = "**"; - } else if (opcode <= INST_STR_NEQ) { + } else if (opcode <= INST_LNOT) { operator = operatorStrings[opcode - INST_LOR]; } -- cgit v0.12