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 2c69a7d61e8e1e30541856b1d29c0e2d7417a972 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 28 Jul 2014 14:50:06 +0000 Subject: Bump to 8.6.2 for release. --- README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 8 files changed, 9 insertions(+), 9 deletions(-) diff --git a/README b/README index 7004bc5..66e1b76 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6.1 source distribution. + This is the Tcl 8.6.2 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index e557290..7531242 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 1 +#define TCL_RELEASE_SERIAL 2 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.1" +#define TCL_PATCH_LEVEL "8.6.2" /* *---------------------------------------------------------------------------- diff --git a/library/init.tcl b/library/init.tcl index bb17319..265f928 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6.1 +package require -exact Tcl 8.6.2 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index bd85ba4..ec5e0ed 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".1" +TCL_PATCH_LEVEL=".2" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/configure.in b/unix/configure.in index cb6cf82..85bd7ee 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".1" +TCL_PATCH_LEVEL=".2" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index 678222c..50aacc6 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6.1 +Version: 8.6.2 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index 2affd38..cf2b201 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".1" +TCL_PATCH_LEVEL=".2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index 77e0327..aa47505 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".1" +TCL_PATCH_LEVEL=".2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From f10bee2648e7e87c576a1afe761e8525255d3a7a Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 30 Jul 2014 16:41:24 +0000 Subject: [3757cdf808] More clock refactoring with spooky impact on [string match] performance. --- generic/tclClock.c | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 524a9e8..9d4bcd6 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -522,6 +522,26 @@ ClockGetdatefieldsObjCmd( */ static int +FetchEraField( + Tcl_Interp *interp, + Tcl_Obj *dict, + Tcl_Obj *key, + int *storePtr) +{ + Tcl_Obj *value = NULL; + + if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) { + return TCL_ERROR; + } + if (value == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "expected key(s) not found in dictionary", -1)); + return TCL_ERROR; + } + return Tcl_GetIndexFromObj(interp, value, eras, "era", TCL_EXACT, storePtr); +} + +static int FetchIntField( Tcl_Interp *interp, Tcl_Obj *dict, @@ -552,7 +572,6 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( Tcl_Obj *dict; ClockClientData *data = clientData; Tcl_Obj *const *literals = data->literals; - Tcl_Obj *fieldPtr; int changeover; int copied = 0; int status; @@ -567,10 +586,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( return TCL_ERROR; } dict = objv[1]; - if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK - || fieldPtr == NULL - || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, - &era) != TCL_OK + if (FetchEraField(interp, dict, literals[LIT_ERA], &era) != TCL_OK || FetchIntField(interp, dict, literals[LIT_YEAR], &fields.year) != TCL_OK || FetchIntField(interp, dict, literals[LIT_MONTH], &fields.month) @@ -640,7 +656,6 @@ ClockGetjuliandayfromerayearweekdayObjCmd( Tcl_Obj *dict; ClockClientData *data = clientData; Tcl_Obj *const *literals = data->literals; - Tcl_Obj *fieldPtr; int changeover; int copied = 0; int status; @@ -655,10 +670,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd( return TCL_ERROR; } dict = objv[1]; - if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK - || fieldPtr == NULL - || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, - &era) != TCL_OK + if (FetchEraField(interp, dict, literals[LIT_ERA], &era) != TCL_OK || FetchIntField(interp, dict, literals[LIT_ISO8601YEAR], &fields.iso8601Year) != TCL_OK || FetchIntField(interp, dict, literals[LIT_ISO8601WEEK], -- cgit v0.12 From 1666ae35d8a1d7fd4183adbcca775f541b8596eb Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 31 Jul 2014 19:58:53 +0000 Subject: [a84a720966] Protect against double free in TclOO classChainCache teardown. --- generic/tclOOCall.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 26fd09f..897f635 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -150,7 +150,7 @@ void TclOODeleteChain( CallChain *callPtr) { - if (--callPtr->refCount >= 1) { + if (callPtr == NULL || --callPtr->refCount >= 1) { return; } if (callPtr->chain != callPtr->staticChain) { -- cgit v0.12 From 039b5c21864604ac410777f49e11d9a11b255d06 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Jul 2014 21:23:45 +0000 Subject: Fix part of [d19aef1487] (broken --disable-load on MacOSX), broken by [4d417791c9] --- generic/tclLoadNone.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index c22c4c4..6cb4378 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -104,7 +104,9 @@ TclpLoadMemory( int size, /* Dummy: unused by this implementation */ int codeSize, /* Dummy: unused by this implementation */ Tcl_LoadHandle *loadHandle, /* Dummy: unused by this implementation */ - Tcl_FSUnloadFileProc **unloadProcPtr) + Tcl_FSUnloadFileProc **unloadProcPtr, + /* Dummy: unused by this implementation */ + int flags) /* Dummy: unused by this implementation */ { Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory " -- cgit v0.12 From 374022fc5dab400eaec3c8af83d78f75e53a488f Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 1 Aug 2014 14:36:30 +0000 Subject: Correction and commentary in the details of ensemble compiling. --- generic/tclEnsemble.c | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 022dafa..763f5a0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3019,8 +3019,24 @@ TclCompileEnsemble( cmdPtr = oldCmdPtr; depth--; } - (void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL); } + /* + * The length of the "replaced" list must be depth-1. Trim back + * any extra elements that might have been appended by failing + * pathways above. + */ + (void) Tcl_ListObjReplace(NULL, replaced, depth-1, INT_MAX, 0, NULL); + + /* + * TODO: Reconsider whether we ought to call CompileToInvokedCommand() + * when depth==1. In that case we are choosing to emit the + * INST_INVOKE_REPLACE bytecode when there is in fact no replacing + * to be done. It would be equally functional and presumably more + * performant to fall through to cleanup below, return TCL_ERROR, + * and let the compiler harness emit the INST_INVOKE_STK + * implementation for us. + */ + CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr); ourResult = TCL_OK; } -- cgit v0.12 From d6128e2e73aa4d49417ff9beddd89216f0df77db Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 1 Aug 2014 16:01:30 +0000 Subject: [e75fabac06] Teardown line information after failed ensemble subcommand compile attempts. Copy/paste from CompileCmdCompileProc(). May be refactor opportunity here. --- generic/tclEnsemble.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 763f5a0..473c4bb 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2749,6 +2749,7 @@ TclCompileEnsemble( int ourResult = TCL_ERROR; unsigned numBytes; const char *word; + DefineLineInformation; Tcl_IncrRefCount(replaced); if (parsePtr->numWords < depth + 1) { @@ -3008,6 +3009,23 @@ TclCompileEnsemble( } /* + * Throw out any line information generated by the failed compile attempt. + */ + + while (mapPtr->nuloc - 1 > eclIndex) { + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; + } + + /* + * Reset the index of next command. Toss out any from failed nested + * partial compiles. + */ + + envPtr->numCommands = mapPtr->nuloc; + + /* * Failed to do a full compile for some reason. Try to do a direct invoke * instead of going through the ensemble lookup process again. */ -- cgit v0.12 From 6f329a1932ac170449caed077ca7f5596709433c Mon Sep 17 00:00:00 2001 From: andreask Date: Fri, 1 Aug 2014 20:07:40 +0000 Subject: Addition of a cast in tclWinFile.c to match types in a comparison, and fix of a TRACE string literal in tclExecute.c with a bogus escape. Both would otherwise bug a Windows debug build (where warnings are errors). --- generic/tclExecute.c | 2 +- win/tclWinFile.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2098e50..2e03ab4 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5079,7 +5079,7 @@ TEBCresume( valuePtr = OBJ_AT_TOS; opnd = TclGetInt4AtPtr(pc+1); - TRACE(("\%.30s\" %d => ", O2S(valuePtr), opnd)); + TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); /* * Get the contents of the list, making sure that it really is a list diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1cdd53f..fe84a26 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -2929,7 +2929,7 @@ TclNativeCreateNativeRep( str = Tcl_GetString(validPathPtr); len = validPathPtr->length; - if (strlen(str)!=len) { + if (strlen(str)!=(unsigned int)len) { /* String contains NUL-bytes. This is invalid. */ return 0; } -- cgit v0.12 From 199f805233d9af1ccfd843748bffd339b275bbab Mon Sep 17 00:00:00 2001 From: ferrieux Date: Sat, 2 Aug 2014 13:04:16 +0000 Subject: TIP 429 Implementation: [string cat] --- doc/string.n | 8 ++++++ generic/tclCmdMZ.c | 71 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclCompCmdsSZ.c | 33 +++++++++++++++++++++++ generic/tclInt.h | 3 +++ tests/string.test | 34 +++++++++++++++++++---- tests/stringComp.test | 38 ++++++++++++++++++++++++-- 6 files changed, 180 insertions(+), 7 deletions(-) diff --git a/doc/string.n b/doc/string.n index 72a69ff..9108e7c 100644 --- a/doc/string.n +++ b/doc/string.n @@ -19,6 +19,14 @@ string \- Manipulate strings Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP +\fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR? +. +Concatenate the given strings just like direct juxtaposition +would. This primitive is occasionally handier than juxtaposition when +mixed quoting is wanted, or when the aim is to return the result of a +concatenation without resorting to \fB[return -level 0]\fR. If no arg +is present, an empty string is returned. +.TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR . Perform a character-by-character comparison of strings \fIstring1\fR diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0f7f20a..ea5d7a4 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2838,6 +2838,76 @@ StringCmpCmd( /* *---------------------------------------------------------------------- * + * StringCatCmd -- + * + * This procedure is invoked to process the "string cat" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringCatCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int tot, i, length; + char *bytes, *p; + Tcl_Obj *objResultPtr; + + /* + * NOTE: this implementation aims for simplicity, not speed, because all + * speed-critical uses of [string cat] will involve the compiled variant + * anyway. Thus we avoid code duplication (from TEBC/INST_CONCAT1) without + * sacrificing perf. + */ + + if (objc < 2) { + /* + * If there are no args, the result is an empty object. + * Just leave the preset empty interp result. + */ + return TCL_OK; + } + tot = 0; + for(i = 1;i < objc;i++) { + bytes = TclGetStringFromObj(objv[i], &length); + if (bytes != NULL) { + tot += length; + } + } + if (tot < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + p = ckalloc(tot + 1); + TclNewObj(objResultPtr); + objResultPtr->bytes = p; + objResultPtr->length = tot; + for (i = 1;i < objc;i++) { + bytes = TclGetStringFromObj(objv[i], &length); + if (bytes != NULL) { + memcpy(p, bytes, (size_t) length); + p += length; + } + } + *p = '\0'; + Tcl_SetObjResult(interp,objResultPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * StringBytesCmd -- * * This procedure is invoked to process the "string bytelength" Tcl @@ -3330,6 +3400,7 @@ TclInitStringCmd( { static const EnsembleImplMap stringImplMap[] = { {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index e6ec0a6..8ade6a5 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -269,6 +269,39 @@ TclCompileSetCmd( */ int +TclCompileStringCatCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + int numWords = parsePtr->numWords; + Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + + if (numWords>=2) { + int i; + + for (i = 1; i < numWords; i++) { + CompileWord(envPtr, wordTokenPtr, interp, i); + wordTokenPtr = TokenAfter(wordTokenPtr); + } + while (numWords > 256) { + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + numWords -= 254; /* concat pushes 1 obj, the result */ + } + if (numWords > 2) { + TclEmitInstInt1(INST_STR_CONCAT1, numWords - 1, envPtr); + } + } else { + PushStringLiteral(envPtr, ""); + } + return TCL_OK; +} + +int TclCompileStringCmpCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclInt.h b/generic/tclInt.h index 1bb2103..6bf1ef9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3646,6 +3646,9 @@ MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringCatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/tests/string.test b/tests/string.test index a8a83d9..54d02e8 100644 --- a/tests/string.test +++ b/tests/string.test @@ -30,7 +30,7 @@ testConstraint memory [llength [info commands memory]] test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2 {error conditions} { list [catch {string} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} @@ -54,7 +54,7 @@ test string-2.6 {string compare} { string compare abcde abdef } -1 test string-2.7 {string compare, shortest method name} { - string c abcde ABCDE + string co abcde ABCDE } 1 test string-2.8 {string compare} { string compare abcde abcde @@ -81,7 +81,7 @@ test string-2.13 {string compare -nocase} { string compare -nocase abcde abdef } -1 test string-2.14 {string compare -nocase} { - string c -nocase abcde ABCDE + string compare -nocase abcde ABCDE } 0 test string-2.15 {string compare -nocase} { string compare -nocase abcde abcde @@ -1513,7 +1513,7 @@ test string-20.1 {string trimright errors} { } {1 {wrong # args: should be "string trimright string ?chars?"}} test string-20.2 {string trimright errors} { list [catch {string trimg a} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3 {string trimright} { string trimright " XYZ " } { XYZ} @@ -1572,7 +1572,7 @@ test string-21.14 {string wordend, unicode} { test string-22.1 {string wordstart} { list [catch {string word a} msg] $msg -} {1 {unknown or ambiguous subcommand "word": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2 {string wordstart} { list [catch {string wordstart a} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} @@ -1969,6 +1969,30 @@ test string-28.13 {tcl::prefix longest} { tcl::prefix longest {ax\x90 bep ax\x91} a } ax +test string-29.1 {string cat, no arg} { + string cat +} "" +test string-29.2 {string cat, single arg} { + set x [pid] + string compare $x [string cat $x] +} 0 +test string-29.3 {string cat, two args} { + set x [pid] + string compare $x$x [string cat $x $x] +} 0 +test string-29.4 {string cat, many args} { + set x [pid] + set n 260 + set xx [string repeat $x $n] + set vv [string repeat {$x} $n] + set vvs [string repeat {$x } $n] + set r1 [string compare $xx [subst $vv]] + set r2 [string compare $xx [eval "string cat $vvs"]] + list $r1 $r2 +} {0 0} + + + # cleanup rename MemStress {} catch {rename foo {}} diff --git a/tests/stringComp.test b/tests/stringComp.test index 165ef20..083399b 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -46,7 +46,7 @@ if {[testConstraint memory]} { test stringComp-1.1 {error conditions} { proc foo {} {string gorp a b} list [catch {foo} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test stringComp-1.2 {error conditions} { proc foo {} {string} list [catch {foo} msg] $msg @@ -210,7 +210,7 @@ foreach {tname tbody tresult tcode} { # need a few extra tests short abbr cmd test stringComp-3.1 {string compare, shortest method name} { - proc foo {} {string c abcde ABCDE} + proc foo {} {string co abcde ABCDE} foo } 1 test stringComp-3.2 {string equal, shortest method name} { @@ -735,6 +735,40 @@ test stringComp-14.2 {Bug 82e7f67325} memory { ## string word* ## not yet bc + +## string cat +test stringComp-29.1 {string cat, no arg} { + proc foo {} {string cat} + foo +} "" +test stringComp-29.2 {string cat, single arg} { + proc foo {} { + set x [pid] + string compare $x [string cat $x] + } + foo +} 0 +test stringComp-29.3 {string cat, two args} { + proc foo {} { + set x [pid] + string compare $x$x [string cat $x $x] + } + foo +} 0 +test stringComp-29.4 {string cat, many args} { + proc foo {} { + set x [pid] + set n 260 + set xx [string repeat $x $n] + set vv [string repeat {$x} $n] + set vvs [string repeat {$x } $n] + set r1 [string compare $xx [subst $vv]] + set r2 [string compare $xx [eval "string cat $vvs"]] + list $r1 $r2 + } + foo +} {0 0} + # cleanup catch {rename foo {}} -- cgit v0.12 From 50e84817bf26eed388c0fb3df70cfb4d00e9eab5 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Sat, 2 Aug 2014 15:26:46 +0000 Subject: Don't use [pid] in tests, stick to constant literals. --- doc/string.n | 2 ++ tests/string.test | 6 +++--- tests/stringComp.test | 6 +++--- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/doc/string.n b/doc/string.n index 9108e7c..450a97b 100644 --- a/doc/string.n +++ b/doc/string.n @@ -19,6 +19,7 @@ string \- Manipulate strings Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP +.VS 8.6.2 \fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR? . Concatenate the given strings just like direct juxtaposition @@ -26,6 +27,7 @@ would. This primitive is occasionally handier than juxtaposition when mixed quoting is wanted, or when the aim is to return the result of a concatenation without resorting to \fB[return -level 0]\fR. If no arg is present, an empty string is returned. +.VE .TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR . diff --git a/tests/string.test b/tests/string.test index 54d02e8..3611753 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1973,15 +1973,15 @@ test string-29.1 {string cat, no arg} { string cat } "" test string-29.2 {string cat, single arg} { - set x [pid] + set x FOO string compare $x [string cat $x] } 0 test string-29.3 {string cat, two args} { - set x [pid] + set x FOO string compare $x$x [string cat $x $x] } 0 test string-29.4 {string cat, many args} { - set x [pid] + set x FOO set n 260 set xx [string repeat $x $n] set vv [string repeat {$x} $n] diff --git a/tests/stringComp.test b/tests/stringComp.test index 083399b..f9f6bda 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -743,21 +743,21 @@ test stringComp-29.1 {string cat, no arg} { } "" test stringComp-29.2 {string cat, single arg} { proc foo {} { - set x [pid] + set x FOO string compare $x [string cat $x] } foo } 0 test stringComp-29.3 {string cat, two args} { proc foo {} { - set x [pid] + set x FOO string compare $x$x [string cat $x $x] } foo } 0 test stringComp-29.4 {string cat, many args} { proc foo {} { - set x [pid] + set x FOO set n 260 set xx [string repeat $x $n] set vv [string repeat {$x} $n] -- cgit v0.12 From 483ef76a4114d3d190ea82c0cdbf88fdb1b9ee9e Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 3 Aug 2014 22:43:42 +0000 Subject: Tidy up the docs --- doc/string.n | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/doc/string.n b/doc/string.n index 450a97b..33780ff 100644 --- a/doc/string.n +++ b/doc/string.n @@ -19,14 +19,19 @@ string \- Manipulate strings Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP -.VS 8.6.2 \fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR? -. -Concatenate the given strings just like direct juxtaposition -would. This primitive is occasionally handier than juxtaposition when -mixed quoting is wanted, or when the aim is to return the result of a -concatenation without resorting to \fB[return -level 0]\fR. If no arg -is present, an empty string is returned. +.VS 8.6.2 +Concatenate the given \fIstring\fRs just like placing them directly +next to each other and return the resulting compound string. If no +\fIstring\fRs are present, the result is an empty string. +.RS +.PP +This primitive is occasionally handier than juxtaposition of strings +when mixed quoting is wanted, or when the aim is to return the result +of a concatenation without resorting to \fBreturn\fR \fB\-level 0\fR, +and is more efficient than building a list of arguments and using +\fBjoin\fR with an empty join string. +.RE .VE .TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR -- cgit v0.12 From 93a502d2ff6f6a849b8307bd531f5b55dea69e24 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Tue, 5 Aug 2014 09:55:54 +0000 Subject: More optimized non-BC [string cat] using Tcl_AppendObjToObj() - thx Donal --- generic/tclCmdMZ.c | 45 ++++++++++++++------------------------------- 1 file changed, 14 insertions(+), 31 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index ea5d7a4..841002f 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2859,17 +2859,9 @@ StringCatCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int tot, i, length; - char *bytes, *p; + int i; Tcl_Obj *objResultPtr; - /* - * NOTE: this implementation aims for simplicity, not speed, because all - * speed-critical uses of [string cat] will involve the compiled variant - * anyway. Thus we avoid code duplication (from TEBC/INST_CONCAT1) without - * sacrificing perf. - */ - if (objc < 2) { /* * If there are no args, the result is an empty object. @@ -2877,30 +2869,21 @@ StringCatCmd( */ return TCL_OK; } - tot = 0; - for(i = 1;i < objc;i++) { - bytes = TclGetStringFromObj(objv[i], &length); - if (bytes != NULL) { - tot += length; - } + if (objc == 2) { + /* + * Other trivial case, single arg, just return it. + */ + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } - if (tot < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - p = ckalloc(tot + 1); - TclNewObj(objResultPtr); - objResultPtr->bytes = p; - objResultPtr->length = tot; - for (i = 1;i < objc;i++) { - bytes = TclGetStringFromObj(objv[i], &length); - if (bytes != NULL) { - memcpy(p, bytes, (size_t) length); - p += length; - } + objResultPtr = objv[1]; + if (Tcl_IsShared(objResultPtr)) { + objResultPtr = Tcl_DuplicateObj(objResultPtr); + } + for(i = 2;i < objc;i++) { + Tcl_AppendObjToObj(objResultPtr, objv[i]); } - *p = '\0'; - Tcl_SetObjResult(interp,objResultPtr); + Tcl_SetObjResult(interp, objResultPtr); return TCL_OK; } -- cgit v0.12 From 60a802acb616e77ccf3cab5328dccaea820f3e66 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Tue, 5 Aug 2014 10:34:10 +0000 Subject: Add constant folding to [string cat]. Mixed-quote idiom is now compiled to a single push. --- generic/tclCompCmdsSZ.c | 62 ++++++++++++++++++++++++++++++++++++------------- 1 file changed, 46 insertions(+), 16 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8ade6a5..bd8b463 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -277,27 +277,57 @@ TclCompileStringCatCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int numWords = parsePtr->numWords; - Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + int i,numWords = parsePtr->numWords; + Tcl_Token *wordTokenPtr; + Tcl_Obj *obj, *folded; DefineLineInformation; /* TIP #280 */ - if (numWords>=2) { - int i; + /* Trivial case, no arg */ - for (i = 1; i < numWords; i++) { - CompileWord(envPtr, wordTokenPtr, interp, i); - wordTokenPtr = TokenAfter(wordTokenPtr); - } - while (numWords > 256) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); - numWords -= 254; /* concat pushes 1 obj, the result */ - } - if (numWords > 2) { - TclEmitInstInt1(INST_STR_CONCAT1, numWords - 1, envPtr); - } - } else { + if (numWords<2) { PushStringLiteral(envPtr, ""); + return TCL_OK; } + + /* Detection of foldable constants. Often used for mixed quoting. */ + + folded = Tcl_NewObj(); + wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i = 1; i < numWords; i++) { + obj = Tcl_NewObj(); + if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) { + Tcl_AppendObjToObj(folded, obj); + } else { + Tcl_DecrRefCount(obj); + Tcl_DecrRefCount(folded); + folded = NULL; + break; + } + wordTokenPtr = TokenAfter(wordTokenPtr); + } + if (folded) { + int len; + const char *bytes = Tcl_GetStringFromObj(folded, &len); + + PushLiteral(envPtr, bytes, len); + return TCL_OK; + } + + /* General case: just issue CONCAT1's (by chunks of 255 if needed) */ + + wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i = 1; i < numWords; i++) { + CompileWord(envPtr, wordTokenPtr, interp, i); + wordTokenPtr = TokenAfter(wordTokenPtr); + } + while (numWords > 256) { + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + numWords -= 254; /* concat pushes 1 obj, the result */ + } + if (numWords > 2) { + TclEmitInstInt1(INST_STR_CONCAT1, numWords - 1, envPtr); + } + return TCL_OK; } -- cgit v0.12 From 201e2d1d6adb55742fd72f75a35c18bba901a0eb Mon Sep 17 00:00:00 2001 From: ferrieux Date: Tue, 5 Aug 2014 11:29:16 +0000 Subject: Better organize [string cat] by chunks of 255 args. --- generic/tclCompCmdsSZ.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index bd8b463..87b1ebb 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -277,7 +277,7 @@ TclCompileStringCatCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int i,numWords = parsePtr->numWords; + int i, numWords = parsePtr->numWords, numArgs; Tcl_Token *wordTokenPtr; Tcl_Obj *obj, *folded; DefineLineInformation; /* TIP #280 */ @@ -315,17 +315,19 @@ TclCompileStringCatCmd( /* General case: just issue CONCAT1's (by chunks of 255 if needed) */ + numArgs = 0; wordTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { CompileWord(envPtr, wordTokenPtr, interp, i); + numArgs ++; + if (numArgs == 255) { + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + numArgs = 1; /* concat pushes 1 obj, the result */ + } wordTokenPtr = TokenAfter(wordTokenPtr); } - while (numWords > 256) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); - numWords -= 254; /* concat pushes 1 obj, the result */ - } - if (numWords > 2) { - TclEmitInstInt1(INST_STR_CONCAT1, numWords - 1, envPtr); + if (numArgs > 1) { + TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); } return TCL_OK; -- cgit v0.12 From 504a1200f71158b91d5d939b25c21c5110985963 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Tue, 5 Aug 2014 18:20:48 +0000 Subject: More aggressive constant folding in [string cat]. Thanks AndreasK for kicking. --- generic/tclCompCmdsSZ.c | 47 +++++++++++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 87b1ebb..fb26430 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -289,19 +289,38 @@ TclCompileStringCatCmd( return TCL_OK; } - /* Detection of foldable constants. Often used for mixed quoting. */ + /* General case: issue CONCAT1's (by chunks of 255 if needed), folding + contiguous constants along the way */ - folded = Tcl_NewObj(); + numArgs = 0; + folded = NULL; wordTokenPtr = TokenAfter(parsePtr->tokenPtr); for (i = 1; i < numWords; i++) { obj = Tcl_NewObj(); if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) { - Tcl_AppendObjToObj(folded, obj); + if (folded) { + Tcl_AppendObjToObj(folded, obj); + Tcl_DecrRefCount(obj); + } else { + folded = obj; + } } else { Tcl_DecrRefCount(obj); - Tcl_DecrRefCount(folded); - folded = NULL; - break; + if (folded) { + int len; + const char *bytes = Tcl_GetStringFromObj(folded, &len); + + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(folded); + folded = NULL; + numArgs ++; + } + CompileWord(envPtr, wordTokenPtr, interp, i); + numArgs ++; + if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */ + TclEmitInstInt1(INST_STR_CONCAT1, 254, envPtr); + numArgs -= 253; /* concat pushes 1 obj, the result */ + } } wordTokenPtr = TokenAfter(wordTokenPtr); } @@ -310,21 +329,9 @@ TclCompileStringCatCmd( const char *bytes = Tcl_GetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); - return TCL_OK; - } - - /* General case: just issue CONCAT1's (by chunks of 255 if needed) */ - - numArgs = 0; - wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i = 1; i < numWords; i++) { - CompileWord(envPtr, wordTokenPtr, interp, i); + Tcl_DecrRefCount(folded); + folded = NULL; numArgs ++; - if (numArgs == 255) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); - numArgs = 1; /* concat pushes 1 obj, the result */ - } - wordTokenPtr = TokenAfter(wordTokenPtr); } if (numArgs > 1) { TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); -- cgit v0.12 From f56a79a4ead94c1a0bb1338f91eff356d141124c Mon Sep 17 00:00:00 2001 From: ferrieux Date: Tue, 5 Aug 2014 22:10:58 +0000 Subject: Fix comment inaccuracy. --- generic/tclCompCmdsSZ.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index fb26430..f2e5dd2 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -289,7 +289,7 @@ TclCompileStringCatCmd( return TCL_OK; } - /* General case: issue CONCAT1's (by chunks of 255 if needed), folding + /* General case: issue CONCAT1's (by chunks of 254 if needed), folding contiguous constants along the way */ numArgs = 0; -- cgit v0.12 From 1b32842190bca544934896869543ba718d86a14d Mon Sep 17 00:00:00 2001 From: andreask Date: Wed, 6 Aug 2014 18:20:56 +0000 Subject: Fixed type conversion warnings which break a Win32 debug build (MSVC). --- generic/tclIO.c | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index c142917..66c0be6 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9048,7 +9048,8 @@ MBWrite( ChannelState *outStatePtr = csPtr->writePtr->state; ChannelBuffer *bufPtr = inStatePtr->inQueueHead; ChannelBuffer *tail = NULL; - int code, inBytes = 0; + int code; + Tcl_WideInt inBytes = 0; /* Count up number of bytes waiting in the input queue */ while (bufPtr) { @@ -9063,7 +9064,14 @@ MBWrite( if (bufPtr) { /* Split the overflowing buffer in two */ - int extra = inBytes - csPtr->toRead; + int extra = (int) (inBytes - csPtr->toRead); + /* Note that going with int for extra assumes that inBytes is not too + * much over toRead to require a wide itself. If that gets violated + * then the calculations involving extra must be made wide too. + * + * Noted with Win32/MSVC debug build treating the warning (possible of + * data in int64 to int conversion) as error. + */ bufPtr = AllocChannelBuffer(extra); -- cgit v0.12 From 1c058969f08127a16e91339f83fc824493ac28cb Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 17 Aug 2014 15:23:49 +0000 Subject: [7d52e1101b] oo::object should know that oo::class is a subclass. --- generic/tclOO.c | 1 + tests/oo.test | 17 +++++++++++++++++ 2 files changed, 18 insertions(+) diff --git a/generic/tclOO.c b/generic/tclOO.c index 02e00c9..ace47fe 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -394,6 +394,7 @@ InitFoundation( fPtr->classCls->flags |= ROOT_CLASS; TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); AddRef(fPtr->objectCls->thisPtr); AddRef(fPtr->objectCls); diff --git a/tests/oo.test b/tests/oo.test index fcd9818..8c515da 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -283,6 +283,23 @@ test oo-1.20 {basic test of OO functionality: my teardown post rename} -body { obj destroy info commands ::AGlobalName } -result {} +test oo-1.21 {basic test of OO functionality: default relations} -setup { + set fresh [interp create] +} -body { + lmap x [$fresh eval { + foreach cmd {instances subclasses mixins superclass} { + foreach initial {object class Slot} { + lappend x [info class $cmd ::oo::$initial] + } + } + foreach initial {object class Slot} { + lappend x [info object class ::oo::$initial] + } + return $x + }] {lsort $x} +} -cleanup { + interp delete $fresh +} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as -- cgit v0.12 From cf4e4a26568bf0458b829d7c1f09f96883617a17 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 19 Aug 2014 18:34:09 +0000 Subject: Update changes file. --- changes | 146 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 144 insertions(+), 2 deletions(-) diff --git a/changes b/changes index 659319c..ab01bed 100644 --- a/changes +++ b/changes @@ -8274,7 +8274,7 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) 2013-08-01 (bug fix)[1905562] RE recursion limit increased to support reported usage of large expressions (porter) -2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows)2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows) +2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows) 2013-08-03 (enhancement)[3611643] [auto_mkindex] support TclOO (fellows) @@ -8303,4 +8303,146 @@ reported usage of large expressions (porter) Many optmizations, improvements, and tightened stack management in bytecode. ---- Released 8.6.1, Septemer 20, 2013 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.1, September 20, 2013 --- http://core.tcl.tk/tcl/ for details + +2013-09-27 (enhancement) improved ::env synchronization (fellows) + +2013-10-20 (bug fix)[2835313] segfault from +[apply {{} {while 1 {a {*}[return -level 0 -code continue]}}}] (fellows) + +2013-10-22 (bug fix)[3556215] [scan %E%G%X] support (fellows) + +2013-10-25 (bug fix)[3eb2ec1] upper case scheme names in url. (nijtmans) +=> http 2.8.8 + +2013-10-29 (bug fix)[414d103] HP-UX: restore [exec] in threaded Tcl (nijtmans) + +2013-11-04 (bug fix) C++ friendly stubs struct declarations (nijtmans) + +2013-11-05 (bug fix)[426679e] OpenBSD man page rendering (nijtmans) + +2013-11-12 (bug fix)[5425f2c] [fconfigure -error] breaks [socket -async] + +2013-11-20 (bug fix) Improved environment variable management (nijtmans) +=> tcltest 2.3.7 + +2013-11-21 (platforms) Support for Windows 8.1 (nijtmans) + +2013-12-06 (RFE) improved [foreach] bytecode (fellows) + +2013-12-10 (RFE) improved [lmap] bytecode (sofer) + +2013-12-11 (RFE) improved [catch] bytecode (sofer) + +2013-12-18 (bug fix)[0b874c3] SEGV [coroutine X coroutine Y info frame] (porter) + +2013-12-20 (RFE) reduced numeric conversion in bytecode (sofer) + +2014-01-07 (RFE) compilers for [concat], [linsert], [namespace origin], +[next], [string replace], [string tolower], [string totitle], [string toupper], +[string trim], [string trimleft], [string trimright] (fellows) + +2014-01-22 (RFE) compilers for [nextto], [yieldto] (fellows) + +2014-02-02 (RFE) compiler for [string is] (fellows) + +2014-02-06 (bug fix)[a4494e2] panic in test namespace-13.2 (porter) + +2014-03-20 (bug fix)[2f7cbd0] FreeBSD 10.0 build failure (nijtmans) + +2014-03-26 (RFE)[b42b208] Cygwin: [file attr -readonly -archive -hidden -system] +(nijtmans) + +2014-03-27 (bug fix) segfault iocmd-23.11 (porter) + +2014-04-04 (bug fix)[581937a,97069ea] async socket connect fail (oehlmann) + +2014-04-10 (bug fix)[792641f] Win: no \ in normalized path (nijtmans) + +2014-04-11 (bug fix)[3118489] protect NUL in filenames (nijtmans) + +2014-04-15 (bug fix)[88aef05] segfault iocmd-21.20 (porter) + +2014-04-16 (update) Win: use Winsock 2.2 (nijtmans) + +2014-04-16 (bug fix)[d19a30d] segfault clock-67.[23] (sebres) + +2014-04-21 (bug fix) segfault iocmd-21.2[12] (porter) + +2014-04-22 (bug fix) segfault iogt-2.4 (porter) + +2014-04-23 (bug fix)[3493120] memleak in thread exit + +2014-05-08 refactoring of core I/O functions (porter) + +2014-05-09 (bug fix)[3389978] Win: extended paths support (nijtmans) + +2014-05-09 (bug fix) segfault iocmd-32.1 (porter) + +2014-05-11 (bug fix)[6d2f249] nested ensemble compile failure (fellows) + +2014-05-17 (RFE)[47d6625] wideint support in [lsearch -integer] [lsort -integer] (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2014-05-20 (bug fix) Stop eof and blocked state leaking thru stacks (porter) + *** POTENTIAL INCOMPATIBILITY *** + +2014-05-28 (platforms) work around systems that fail when a shared library +is deleted after it is [load]ed (kupries) + +2014-05-31 (bug fix) chan events on pipes must be on proper ends (porter) + +2014-06-04 (bug fix) socket-2.12 (porter) + +2014-06-05 (bug fix) io-12.6 (kupries,porter) + +2014-06-15 (RFE)[1b0266d] [dict replace|remove] return canonical dict (fellows) + *** POTENTIAL INCOMPATIBILITY *** + +2014-06-16 (bug fix) socket-2.13 workaround broken select() (porter) + +2014-06-20 (bug fix)[b47b176] iortrans.tf-11.0 (porter) + +2014-06-22 (RFE)[2f9df4c] -cleanup scripts before -out compare (nijtmans) + +2014-07-04 (update) Update Unicode data to 7.0 (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2014-07-08 (bug) [chan push] converts blocked writes to error (aspect,porter) + +2014-07-10 (bug fix)[7368d2] memleak Tcl_SetVar2(..,TCL_APPEND_VALUE) (porter) + *** POTENTIAL INCOMPATIBILITY *** + +2014-07-11 (bug) leaks in SetFsPathFromAny, [info frame] (porter) + +2014-07-15 (bug) compress dict leak in zlib xform channel close (porter) + +2014-07-17 (bug fix)[9969cf8] leak trace data in coroutine deletion (porter) + +2014-07-18 (RFE)[b43f2b4] fix [lappend] multi performance collapse (fellows) + +2014-07-19 (bug fix)[75b8433] memleak managing oo instance lists (porter) + +2014-07-21 (bug fix)[e6477e1] memleak in AtForkChild() (porter) + +2014-07-22 (bug fix)[12b0997] memleak in iocmd.tf-32.0 (porter) + +2014-07-28 (RFE) Optimized binary [chan copy] by moving buffers (porter) + +2014-07-30 (enhancement) use refcounts, not Tcl_Preserve to manage lifetime +of Tcl_Channel (porter) + *** POTENTIAL INCOMPATIBILITY *** + +2014-07-31 (bug fix)[a84a720] double free in oo chain deletion (porter) + +2014-08-01 (bug fix)[e75faba] SEGV [apply {{} {namespace upvar a b [x]}}] (porter) + +2014-08-01 (update) "macosx*-i386-x86_64" "macosx-universal" no longer compatible (kupries) +=> platform 1.0.13 + +2014-08-12 tzdata updated to Olson's tzdata2014f (kenny) + +2014-08-17 (bug fix)[7d52e11] [info class subclasses oo::object] should +include ::oo::class (fellows) + +--- Released 8.6.2, August, 2014 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From 58a456c528984bf6b55516fc1f7ede1a0e542627 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 20 Aug 2014 14:28:36 +0000 Subject: Additions to changes. --- changes | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/changes b/changes index ab01bed..6cf3321 100644 --- a/changes +++ b/changes @@ -8355,6 +8355,8 @@ Many optmizations, improvements, and tightened stack management in bytecode. 2014-03-27 (bug fix) segfault iocmd-23.11 (porter) +2014-04-02 (bug fix)[581937a] Win: readable event on async connect failure + 2014-04-04 (bug fix)[581937a,97069ea] async socket connect fail (oehlmann) 2014-04-10 (bug fix)[792641f] Win: no \ in normalized path (nijtmans) @@ -8387,6 +8389,8 @@ Many optmizations, improvements, and tightened stack management in bytecode. 2014-05-20 (bug fix) Stop eof and blocked state leaking thru stacks (porter) *** POTENTIAL INCOMPATIBILITY *** +2014-05-20 (bug fix)[13d3af3] Win: socket -async tried only first IP address + 2014-05-28 (platforms) work around systems that fail when a shared library is deleted after it is [load]ed (kupries) -- cgit v0.12 From 97233951bf545594a0228fb983dc8d62442a8aa9 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 22 Aug 2014 21:52:37 +0000 Subject: Bump to TclOO 1.0.2 --- generic/tclOO.h | 2 +- unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclOO.h b/generic/tclOO.h index a6e8a22..24d3e6f 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,7 +24,7 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0.1" +#define TCLOO_VERSION "1.0.2" #define TCLOO_PATCHLEVEL TCLOO_VERSION #include "tcl.h" diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 08cc4c5..14b0d8d 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0.1 +TCLOO_VERSION=1.0.2 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 08cc4c5..14b0d8d 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0.1 +TCLOO_VERSION=1.0.2 -- cgit v0.12 From e7501c3ad0279f913c75f93eae9e7d74bf49ea85 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 22 Aug 2014 22:11:13 +0000 Subject: Bump to zlib 2.0.1. --- generic/tclZlib.c | 2 +- tests/zlib.test | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 06e18fe..956e3f9 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -26,7 +26,7 @@ * interface, even if that is mostly true). */ -#define TCL_ZLIB_VERSION "2.0" +#define TCL_ZLIB_VERSION "2.0.1" /* * Magic flags used with wbits fields to indicate that we're handling the gzip diff --git a/tests/zlib.test b/tests/zlib.test index 2346ec7..b1d43fb 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -35,7 +35,7 @@ test zlib-1.3 {zlib basics} -constraints zlib -body { } -result zlibVersion test zlib-1.4 {zlib basics} -constraints zlib -body { package present zlib -} -result 2.0 +} -result 2.0.1 test zlib-2.1 {zlib compress/decompress} zlib { zlib decompress [zlib compress abcdefghijklm] -- cgit v0.12 From 963fffad6be76adc9f12bbe25fa6cb828e93aac0 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 25 Aug 2014 13:51:31 +0000 Subject: Do not let fossil README droppings leak into distribuion --- unix/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 1b2ccf1..0d9b9f0 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1975,7 +1975,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic - cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README* \ + cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README \ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \ $(DISTDIR) @mkdir $(DISTDIR)/library -- cgit v0.12 From 85b2c63c51c49dc03b1b29f3d8b14dcde5501680 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Aug 2014 07:53:24 +0000 Subject: [b9e1a3032e] Implement the documented method search order for TclOO. This corrects the relative positions of object-defined methods and class mixins. --- generic/tclOOCall.c | 97 +++++++++++++++++++++++++++++++++++++++-------------- tests/ooNext2.test | 87 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 158 insertions(+), 26 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 897f635..2a81091 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -38,6 +38,12 @@ struct ChainBuilder { #define DEFINITE_PUBLIC 0x200000 #define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC) #define SPECIAL (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN) +#define BUILDING_MIXINS 0x400000 +#define TRAVERSED_MIXIN 0x800000 +#define OBJECT_MIXIN 0x1000000 +#define MIXIN_CONSISTENT(flags) \ + (((flags) & OBJECT_MIXIN) || \ + !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) /* * Function declarations for things defined in this file. @@ -45,13 +51,13 @@ struct ChainBuilder { static void AddClassFiltersToCallContext(Object *const oPtr, Class *clsPtr, struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters); + Tcl_HashTable *const doneFilters, int flags); static void AddClassMethodNames(Class *clsPtr, const int flags, Tcl_HashTable *const namesPtr); static inline void AddMethodToCallChain(Method *const mPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, - Class *const filterDecl); + Class *const filterDecl, int flags); static inline void AddSimpleChainToCallContext(Object *const oPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, @@ -434,7 +440,7 @@ TclOOGetSortedMethodList( AddClassMethodNames(oPtr->selfCls, flags, &names); FOREACH(mixinPtr, oPtr->mixins) { - AddClassMethodNames(mixinPtr, flags, &names); + AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names); } /* @@ -598,7 +604,7 @@ AddClassMethodNames( /* TODO: Beware of infinite loops! */ FOREACH(mixinPtr, clsPtr->mixins) { - AddClassMethodNames(mixinPtr, flags, namesPtr); + AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, namesPtr); } } @@ -695,13 +701,13 @@ AddSimpleChainToCallContext( FOREACH(mixinPtr, oPtr->mixins) { AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); } if (oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); if (hPtr != NULL) { AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr, - doneFilters, filterDecl); + doneFilters, filterDecl, flags); } } } @@ -732,9 +738,15 @@ AddMethodToCallChain( * processed. If NULL, not processing filters. * Note that this function does not update * this hashtable. */ - Class *const filterDecl) /* The class that declared the filter. If + Class *const filterDecl, /* The class that declared the filter. If * NULL, either the filter was declared by the * object or this isn't a filter. */ + int flags) /* Used to check if we're mixin-consistent + * only. Mixin-consistent means that either + * we're looking to add things from a mixin + * and we have passed a mixin, or we're not + * looking to add things from a mixin and have + * not passed a mixin. */ { register CallChain *callPtr = cbPtr->callChainPtr; int i; @@ -743,9 +755,11 @@ AddMethodToCallChain( * Return if this is just an entry used to record whether this is a public * method. If so, there's nothing real to call and so nothing to add to * the call chain. + * + * This is also where we enforce mixin-consistency. */ - if (mPtr == NULL || mPtr->typePtr == NULL) { + if (mPtr == NULL || mPtr->typePtr == NULL || !MIXIN_CONSISTENT(flags)) { return; } @@ -1001,6 +1015,8 @@ TclOOGetCallContext( if (flags & FORCE_UNKNOWN) { AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; @@ -1024,21 +1040,32 @@ TclOOGetCallContext( doFilters = 1; Tcl_InitObjHashTable(&doneFilters); FOREACH(mixinPtr, oPtr->mixins) { - AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters); + AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters, + TRAVERSED_MIXIN|BUILDING_MIXINS|OBJECT_MIXIN); + AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters, + OBJECT_MIXIN); } FOREACH(filterObj, oPtr->filters) { + AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, + BUILDING_MIXINS, NULL); AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, NULL); } - AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters); + AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, + BUILDING_MIXINS); + AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, + 0); Tcl_DeleteHashTable(&doneFilters); } count = cb.filterLength = callPtr->numChain; /* - * Add the actual method implementations. + * Add the actual method implementations. We have to do this twice to + * handle class mixins right. */ + AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, + flags|BUILDING_MIXINS, NULL); AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); /* @@ -1058,6 +1085,8 @@ TclOOGetCallContext( return NULL; } AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; @@ -1201,7 +1230,9 @@ TclOOGetStereotypeCallChain( */ Tcl_InitObjHashTable(&doneFilters); - AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters); + AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters, + BUILDING_MIXINS); + AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters, 0); Tcl_DeleteHashTable(&doneFilters); count = cb.filterLength = callPtr->numChain; @@ -1209,6 +1240,8 @@ TclOOGetStereotypeCallChain( * Add the actual method implementations. */ + AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, + flags|BUILDING_MIXINS, NULL); AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); /* @@ -1219,6 +1252,8 @@ TclOOGetStereotypeCallChain( if (count == callPtr->numChain) { AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, + NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; @@ -1259,12 +1294,15 @@ AddClassFiltersToCallContext( Class *clsPtr, /* Class to get the filters from. */ struct ChainBuilder *const cbPtr, /* Context to fill with call chain entries. */ - Tcl_HashTable *const doneFilters) + Tcl_HashTable *const doneFilters, /* Where to record what filters have been * processed. Keys are objects, values are * ignored. */ + int flags) /* Whether we've gone along a mixin link + * yet. */ { - int i; + int i, clearedFlags = + flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS); Class *superPtr, *mixinPtr; Tcl_Obj *filterObj; @@ -1279,7 +1317,8 @@ AddClassFiltersToCallContext( */ FOREACH(mixinPtr, clsPtr->mixins) { - AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters); + AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters, + flags|TRAVERSED_MIXIN); } /* @@ -1288,13 +1327,18 @@ AddClassFiltersToCallContext( * override how filters work to extend their behaviour. */ - FOREACH(filterObj, clsPtr->filters) { - int isNew; + if (MIXIN_CONSISTENT(flags)) { + FOREACH(filterObj, clsPtr->filters) { + int isNew; - (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); - if (isNew) { - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, doneFilters, - 0, clsPtr); + (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, + &isNew); + if (isNew) { + AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); + AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + doneFilters, clearedFlags, clsPtr); + } } } @@ -1308,7 +1352,8 @@ AddClassFiltersToCallContext( goto tailRecurse; default: FOREACH(superPtr, clsPtr->superclasses) { - AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters); + AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters, + flags); } case 0: return; @@ -1355,16 +1400,16 @@ AddSimpleClassChainToCallContext( tailRecurse: FOREACH(superPtr, classPtr->mixins) { AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); } if (flags & CONSTRUCTOR) { AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters, - filterDecl); + filterDecl, flags); } else if (flags & DESTRUCTOR) { AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters, - filterDecl); + filterDecl, flags); } else { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, (char *) methodNameObj); @@ -1383,7 +1428,7 @@ AddSimpleClassChainToCallContext( flags |= DEFINITE_PROTECTED; } } - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl); + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } } diff --git a/tests/ooNext2.test b/tests/ooNext2.test index a47aa91..9a63577 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -526,6 +526,93 @@ test oo-call-1.19 {object call introspection - memory leaks} -setup { } -cleanup { leaktester destroy } -constraints memory -result 0 +test oo-call-1.20 {object call introspection - complex case} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + oo::class create ::C { + superclass root + method x {} {} + mixin B + } + oo::class create ::D { + superclass C + method x {} {} + } + oo::class create ::E { + superclass root + method x {} {} + } + oo::class create ::F { + superclass E + method x {} {} + } + oo::class create ::G { + superclass root + method x {} {} + } + oo::class create ::H { + superclass G + method x {} {} + } + oo::define F mixin H + F create y + oo::objdefine y { + method x {} {} + mixin D + } + info object call y x +} -cleanup { + root destroy +} -result {{method x ::D method} {method x ::B method} {method x ::A method} {method x ::C method} {method x ::H method} {method x ::G method} {method x object method} {method x ::F method} {method x ::E method}} +test oo-call-1.21 {object call introspection - complex case} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method y {} {} + } + oo::class create ::C { + superclass root + method x {} {} + mixin B + } + oo::class create ::D { + superclass C + filter x + } + oo::class create ::E { + superclass root + method y {} {} + method x {} {} + } + oo::class create ::F { + superclass E + method z {} {} + method q {} {} + } + F create y + oo::objdefine y { + method unknown {} {} + mixin D + filter q + } + info object call y z +} -cleanup { + root destroy +} -result {{filter x ::C method} {filter x ::E method} {filter y ::B method} {filter y ::A method} {filter y ::E method} {filter q ::F method} {method z ::F method}} test oo-call-2.1 {class call introspection} -setup { oo::class create root -- cgit v0.12 From 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 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 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 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 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 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 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 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 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 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 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 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 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 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 a03c9da848ffd7e60101c43321e05f79635f8cef Mon Sep 17 00:00:00 2001 From: andreask Date: Mon, 1 Dec 2014 20:17:04 +0000 Subject: Fix missing export of the "NewForeachInfoType" AuxData structure for tbcload/tclcompiler packages. --- generic/tclCompile.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 3736498..0f4dfaf 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -4342,10 +4342,11 @@ TclInitAuxDataTypeTable(void) Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); /* - * There are only three AuxData types at this time, so register them here. + * There are only four AuxData types at this time, so register them here. */ RegisterAuxDataType(&tclForeachInfoType); + RegisterAuxDataType(&tclNewForeachInfoType); RegisterAuxDataType(&tclJumptableInfoType); RegisterAuxDataType(&tclDictUpdateInfoType); } -- cgit v0.12 From 6e6e7b2c773fb61f034c68c04bf90e48cacce161 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Wed, 3 Dec 2014 13:22:53 +0000 Subject: adding a test for the bug --- tests/compile.test | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/tests/compile.test b/tests/compile.test index 22ebc7d..8150622 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -455,14 +455,22 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} { list [catch {exec [interpreter] << $script} msg] $msg } {0 OK} -# Special test for compiling tokens from a copy of the source string. [Bug -# 599788] +# Tests compile-14.* for compiling tokens from a copy of the source string. +# [Bug 599788] [Bug 0c043a175a47da8c2342] test compile-14.1 {testing errors in element name; segfault?} {} { catch {set a([error])} msg1 catch {set bubba([join $abba $jubba]) $vol} msg2 list $msg1 $msg2 } {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}} +test compile-14.2 {testing element name "$"} -body { + unset a + set a() 1 + set a($) 2 + list [set a()] [set a($)] [unset a(); lindex [array names a] 0] +} -cleanup {unset a} -result {1 2 $} + + # Tests compile-15.* cover Tcl Bug 633204 test compile-15.1 {proper TCL_RETURN code from [return]} { apply {{} {catch return}} -- cgit v0.12 From 9e5f0ade58641b9719e70838d98e562c867193dd Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 3 Dec 2014 23:05:15 +0000 Subject: [0dca3bfa8f] Strengthen validity checks on fast-path string comparison. --- generic/tclExecute.c | 8 +++++--- tests/stringComp.test | 8 ++++++++ 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 337a75f..b9da8fc 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5410,8 +5410,8 @@ TEBCresume( s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); memCmpFn = memcmp; - } else if (((valuePtr->typePtr == &tclStringType) - && (value2Ptr->typePtr == &tclStringType))) { + } else if ((valuePtr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &tclStringType)) { /* * Do a unicode-specific comparison if both of the args are of * String type. If the char length == byte length, we can do a @@ -5422,7 +5422,9 @@ TEBCresume( s1len = Tcl_GetCharLength(valuePtr); s2len = Tcl_GetCharLength(value2Ptr); if ((s1len == valuePtr->length) - && (s2len == value2Ptr->length)) { + && (valuePtr->bytes != NULL) + && (s2len == value2Ptr->length) + && (value2Ptr->bytes != NULL)) { s1 = valuePtr->bytes; s2 = value2Ptr->bytes; memCmpFn = memcmp; diff --git a/tests/stringComp.test b/tests/stringComp.test index f9f6bda..a66525e 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -720,6 +720,14 @@ test stringComp-14.2 {Bug 82e7f67325} memory { }} {a b} } } {0} +test stringComp-14.3 {Bug 0dca3bfa8f} { + apply {arg { + set argCopy $arg + set arg [string replace $arg 1 2 aa] + # Crashes in comparison before fix + expr {$arg ne $argCopy} + }} abcde +} 1 ## string tolower ## not yet bc -- cgit v0.12 From 3e76a216e3a989a6dbaefd832a0a2dc795672e2e Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Wed, 3 Dec 2014 23:17:16 +0000 Subject: test and fix (thx dgp) --- generic/tclCompCmds.c | 2 +- tests/compile.test | 9 +++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 18f4564..4e7ef97 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3373,7 +3373,7 @@ TclPushVarName( nameChars = p - varTokenPtr[1].start; elName = p + 1; remainingChars = (varTokenPtr[2].start - p) - 1; - elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2; + elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1; if (remainingChars) { /* diff --git a/tests/compile.test b/tests/compile.test index 8150622..45d69e9 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -464,11 +464,12 @@ test compile-14.1 {testing errors in element name; segfault?} {} { } {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}} test compile-14.2 {testing element name "$"} -body { - unset a + unset -nocomplain a set a() 1 - set a($) 2 - list [set a()] [set a($)] [unset a(); lindex [array names a] 0] -} -cleanup {unset a} -result {1 2 $} + set a(1) 2 + set a($) 3 + list [set a()] [set a(1)] [set a($)] [unset a(); lindex [array names a] 0] +} -cleanup {unset a} -result [list 1 2 3 {$}] # Tests compile-15.* cover Tcl Bug 633204 -- cgit v0.12 From 4c172f0d7b93eab8a18f90506049970fc39cf06c Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Wed, 3 Dec 2014 23:34:36 +0000 Subject: missing unset in new test --- tests/compile.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/compile.test b/tests/compile.test index 45d69e9..7335293 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -468,7 +468,7 @@ test compile-14.2 {testing element name "$"} -body { set a() 1 set a(1) 2 set a($) 3 - list [set a()] [set a(1)] [set a($)] [unset a(); lindex [array names a] 0] + list [set a()] [set a(1)] [set a($)] [unset a() a(1); lindex [array names a] 0] } -cleanup {unset a} -result [list 1 2 3 {$}] -- cgit v0.12