diff options
-rw-r--r-- | ChangeLog | 42 | ||||
-rw-r--r-- | README | 2 | ||||
-rw-r--r-- | changes | 6 | ||||
-rw-r--r-- | generic/tcl.h | 4 | ||||
-rw-r--r-- | generic/tclAssembly.c | 243 | ||||
-rw-r--r-- | generic/tclBasic.c | 8 | ||||
-rw-r--r-- | generic/tclFileName.c | 14 | ||||
-rw-r--r-- | generic/tclIO.c | 9 | ||||
-rw-r--r-- | generic/tclIORChan.c | 43 | ||||
-rw-r--r-- | generic/tclIORTrans.c | 36 | ||||
-rw-r--r-- | generic/tclObj.c | 27 | ||||
-rw-r--r-- | generic/tclProc.c | 9 | ||||
-rwxr-xr-x | generic/tclStrToD.c | 6 | ||||
-rw-r--r-- | generic/tclVar.c | 3 | ||||
-rw-r--r-- | generic/tclZlib.c | 18 | ||||
-rw-r--r-- | library/init.tcl | 2 | ||||
-rw-r--r-- | tests/ioTrans.test | 2 | ||||
-rw-r--r-- | tools/tcl.wse.in | 2 | ||||
-rwxr-xr-x | unix/configure | 2 | ||||
-rw-r--r-- | unix/configure.in | 2 | ||||
-rw-r--r-- | unix/tcl.spec | 2 | ||||
-rwxr-xr-x | win/configure | 2 | ||||
-rw-r--r-- | win/configure.in | 2 |
23 files changed, 248 insertions, 238 deletions
@@ -1,3 +1,30 @@ +2011-08-05 Don Porter <dgp@users.sourceforge.net> + + *** 8.6b2 TAGGED FOR RELEASE *** + + * changes: Updates for 8.6b2 release. + +2011-08-05 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclAssembly.c (AssembleOneLine): Ensure that memory isn't + leaked when an unknown instruction is encountered. Also simplify code + through use of Tcl_ObjPrintf in error message generation. + + * generic/tclZlib.c (ZlibTransformClose): [Bug 3386197]: Plug a memory + leak found by Miguel with valgrind, and ensure that the correct + direction's buffers are released. + +2011-08-04 Miguel Sofer <msofer@users.sf.net> + + * generic/tclVar.c (TclPtrSetVar): Fix valgrind-detected error when + newValuePtr is the interp's result obj. + +2011-08-04 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclAssembly.c (FreeAssemblyEnv): [Bug 3384840]: Plug another + possible memory leak due to over-complex code for freeing the table of + labels. + 2011-08-04 Donal K. Fellows <dkf@users.sf.net> * generic/tclAssembly.c (AssembleOneLine, GetBooleanOperand) @@ -102,6 +129,19 @@ * doc/upvar.n: Undocument long gone limitation of [upvar]. +2011-07-18 Don Porter <dgp@users.sourceforge.net> + + * generic/tcl.h: Bump version number to 8.6b2. + * library/init.tcl: + * unix/configure.in: + * win/configure.in: + * unix/tcl.spec: + * tools/tcl.wse.in: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + 2011-07-15 Don Porter <dgp@users.sourceforge.net> * generic/tclCompile.c: Avoid segfaults when RecordByteCodeStats() @@ -132,7 +172,7 @@ 2011-07-07 Miguel Sofer <msofer@users.sf.net> - * generic/tclBasic.c: add missing INT2PTR + * generic/tclBasic.c: Add missing INT2PTR 2011-07-03 Donal K. Fellows <dkf@users.sf.net> @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6b1 source distribution. + This is the Tcl 8.6b2 source distribution. http://tcl.sourceforge.net/ You can get any source release of Tcl from the file distributions link at the above URL. @@ -7532,7 +7532,7 @@ evaluation in extensions (sofer,kenny) 2009-05-08 (bug fix)[2414858] tailcall in oo constructor (fellows) -2009-05-14 (new subcommand) [info object namespace] (fellows) +2009-05-14 (new subcommand)[TIP 354] [info object namespace] (fellows) 2009-05-29 (platform support) account for ia64_32 (kupries) => platform 1.0.5 @@ -7563,7 +7563,7 @@ avoid otherwise very tricky multi-thread finalization bugs. (staplin,ferrieux) 2009-07-16 (bug fix)[2819200] underflow settings on MIPS systems (porter) -2009-07-19 (interface) new public routine Tcl_GetObjectName() (fellows) +2009-07-19 (interface)[TIP 354] new routine Tcl_GetObjectName() (fellows) 2009-07-20 (performance) favor [string is] success cases over empty (fellows) @@ -7953,4 +7953,4 @@ memory with buffer backup (ferrieux) Many more Tcl built-in command errors now set an -errorcode. ---- Released 8.6b2, August 5, 2011 --- See ChangeLog for details --- +--- Released 8.6b2, August 8, 2011 --- See ChangeLog for details --- diff --git a/generic/tcl.h b/generic/tcl.h index 7644e63..54bfedc 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -58,10 +58,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_BETA_RELEASE -#define TCL_RELEASE_SERIAL 1 +#define TCL_RELEASE_SERIAL 2 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6b1.2" +#define TCL_PATCH_LEVEL "8.6b2" /* *---------------------------------------------------------------------------- diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index e12d0f8..f45ae07 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1,5 +1,5 @@ /* - * tclAssembly,c -- + * tclAssembly.c -- * * Assembler for Tcl bytecodes. * @@ -84,7 +84,7 @@ typedef struct BasicBlock { * unresolved */ int initialStackDepth; /* Absolute stack depth on entry */ int minStackDepth; /* Low-water relative stack depth */ - int maxStackDepth; /* High-water relative stack depth */ + int maxStackDepth; /* High-water relative stack depth */ int finalStackDepth; /* Relative stack depth on exit */ enum BasicBlockCatchState catchState; /* State of the block for 'catch' analysis */ @@ -193,7 +193,7 @@ typedef enum TalInstType { typedef struct TalInstDesc { const char *name; /* Name of instruction. */ - TalInstType instType; /* The type of instruction */ + TalInstType instType; /* The type of instruction */ int tclInstCode; /* Instruction code. For instructions having * 1- and 4-byte variables, tclInstCode is * ((1byte)<<8) || (4byte) */ @@ -831,16 +831,20 @@ CompileAssembleObj( if (objPtr->typePtr == &assembleCodeType) { namespacePtr = iPtr->varFramePtr->nsPtr; codePtr = objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch) - || (codePtr->localCachePtr - != iPtr->varFramePtr->localCachePtr)) { - FreeAssembleCodeInternalRep(objPtr); - } else { + if (((Interp *) *codePtr->interpHandle == iPtr) + && (codePtr->compileEpoch == iPtr->compileEpoch) + && (codePtr->nsPtr == namespacePtr) + && (codePtr->nsEpoch == namespacePtr->resolverEpoch) + && (codePtr->localCachePtr + == iPtr->varFramePtr->localCachePtr)) { return codePtr; } + + /* + * Not valid, so free it and regenerate. + */ + + FreeAssembleCodeInternalRep(objPtr); } /* @@ -967,7 +971,7 @@ TclCompileAssembleCmd( static int TclAssembleCode( - CompileEnv *envPtr, /* Compilation environment that is to receive + CompileEnv *envPtr, /* Compilation environment that is to receive * the generated bytecode */ const char* codePtr, /* Assembly-language code to be processed */ int codeLen, /* Length of the code */ @@ -1173,24 +1177,10 @@ FreeAssemblyEnv( } /* - * Free the label hash. - */ - - while (1) { - Tcl_HashEntry* hashEntry; - Tcl_HashSearch hashSearch; - - hashEntry = Tcl_FirstHashEntry(&assemEnvPtr->labelHash, &hashSearch); - if (hashEntry == NULL) { - break; - } - Tcl_DeleteHashEntry(hashEntry); - } - - /* * Dispose what's left. */ + Tcl_DeleteHashTable(&assemEnvPtr->labelHash); TclStackFree(interp, assemEnvPtr->parsePtr); TclStackFree(interp, assemEnvPtr); } @@ -1222,13 +1212,12 @@ AssembleOneLine( Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; /* Parse of the line of code */ Tcl_Token* tokenPtr; /* Current token within the line of code */ - Tcl_Obj* instNameObj = NULL; - /* Name of the instruction */ + Tcl_Obj* instNameObj; /* Name of the instruction */ int tblIdx; /* Index in TalInstructionTable of the * instruction */ enum TalInstType instType; /* Type of the instruction */ Tcl_Obj* operand1Obj = NULL; - /* First operand to the instruction */ + /* First operand to the instruction */ const char* operand1; /* String rep of the operand */ int operand1Len; /* String length of the operand */ int opnd; /* Integer representation of an operand */ @@ -1255,7 +1244,7 @@ AssembleOneLine( if (Tcl_GetIndexFromObjStruct(interp, instNameObj, &TalInstructionTable[0].name, sizeof(TalInstDesc), "instruction", TCL_EXACT, &tblIdx) != TCL_OK) { - return TCL_ERROR; + goto cleanup; } /* @@ -1324,8 +1313,11 @@ AssembleOneLine( Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName"); goto cleanup; } - if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) { + if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { goto cleanup; } BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); @@ -1363,8 +1355,11 @@ AssembleOneLine( goto cleanup; } if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK - || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) { + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); @@ -1377,8 +1372,11 @@ AssembleOneLine( goto cleanup; } if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK - || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) { + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); @@ -1572,7 +1570,8 @@ AssembleOneLine( Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } - if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) { + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { goto cleanup; } BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0); @@ -1583,8 +1582,8 @@ AssembleOneLine( Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } - if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0 - || CheckOneByte(interp, localVar)) { + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0 || CheckOneByte(interp, localVar)) { goto cleanup; } BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); @@ -1595,8 +1594,8 @@ AssembleOneLine( Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); goto cleanup; } - if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0 - || CheckOneByte(interp, localVar) + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0 || CheckOneByte(interp, localVar) || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK || CheckSignedOneByte(interp, opnd)) { goto cleanup; @@ -1610,7 +1609,8 @@ AssembleOneLine( Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } - if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) { + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0); @@ -1672,8 +1672,11 @@ AssembleOneLine( Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) { + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0); @@ -1687,9 +1690,7 @@ AssembleOneLine( status = TCL_OK; cleanup: - if (instNameObj) { - Tcl_DecrRefCount(instNameObj); - } + Tcl_DecrRefCount(instNameObj); if (operand1Obj) { Tcl_DecrRefCount(operand1Obj); } @@ -1871,7 +1872,7 @@ MoveExceptionRangesToBasicBlock( curr_bb, exceptionCount, savedExceptArrayNext); curr_bb->foreignExceptionBase = savedExceptArrayNext; curr_bb->foreignExceptionCount = exceptionCount; - curr_bb->foreignExceptions = + curr_bb->foreignExceptions = ckalloc(exceptionCount * sizeof(ExceptionRange)); memcpy(curr_bb->foreignExceptions, envPtr->exceptArrayPtr + savedExceptArrayNext, @@ -1918,7 +1919,6 @@ CreateMirrorJumpTable( Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */ int isNew; /* Flag==1 if the key is not yet in the * table. */ - Tcl_Obj* result; /* Error message */ int i; if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { @@ -1954,17 +1954,15 @@ CreateMirrorJumpTable( &isNew); if (!isNew) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - result = Tcl_NewStringObj( - "duplicate entry in jump table for \"", -1); - Tcl_AppendObjToObj(result, objv[i]); - Tcl_AppendToObj(result, "\"", -1); - Tcl_SetObjResult(interp, result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "duplicate entry in jump table for \"%s\"", + Tcl_GetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); DeleteMirrorJumpTable(jtPtr); return TCL_ERROR; } } - Tcl_SetHashValue(hashEntry, (ClientData) objv[i+1]); + Tcl_SetHashValue(hashEntry, objv[i+1]); Tcl_IncrRefCount(objv[i+1]); } DEBUG_PRINT("}\n"); @@ -2243,8 +2241,8 @@ FindLocalVar( Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ Tcl_Token* tokenPtr = *tokenPtrPtr; - /* INOUT: Pointer to the next token - * in the source code */ + /* INOUT: Pointer to the next token in the + * source code. */ Tcl_Obj* varNameObj; /* Name of the variable */ const char* varNameStr; int varNameLen; @@ -2255,6 +2253,7 @@ FindLocalVar( } varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { + Tcl_DecrRefCount(varNameObj); return -1; } localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); @@ -2293,14 +2292,12 @@ CheckNamespaceQualifiers( const char* name, /* Variable name to check */ int nameLen) /* Length of the variable */ { - Tcl_Obj* result; /* Error message */ const char* p; + for (p = name; p+2 < name+nameLen; p++) { if ((*p == ':') && (p[1] == ':')) { - result = Tcl_NewStringObj("variable \"", -1); - Tcl_AppendToObj(result, name, -1); - Tcl_AppendToObj(result, "\" is not local", -1); - Tcl_SetObjResult(interp, result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "variable \"%s\" is not local", name)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL); return TCL_ERROR; } @@ -2471,7 +2468,6 @@ DefineLabel( Tcl_HashEntry* entry; /* Label's entry in the symbol table */ int isNew; /* Flag == 1 iff the label was previously * undefined */ - Tcl_Obj* result; /* Error message */ /* TODO - This can now be simplified! */ @@ -2487,14 +2483,11 @@ DefineLabel( * This is a duplicate label. */ - if (assemEnvPtr-> flags & (TCL_EVAL_DIRECT)) { - result = Tcl_NewStringObj( - "duplicate definition of label \"", -1); - Tcl_AppendToObj(result, labelName, -1); - Tcl_AppendToObj(result, "\"", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", - labelName, NULL); + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "duplicate definition of label \"%s\"", labelName)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName, + NULL); } return TCL_ERROR; } @@ -2531,7 +2524,7 @@ StartBasicBlock( { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ - BasicBlock* newBB; /* BasicBlock structure for the new block */ + BasicBlock* newBB; /* BasicBlock structure for the new block */ BasicBlock* currBB = assemEnvPtr->curr_bb; /* @@ -2693,8 +2686,10 @@ FinishAssembly( return TCL_ERROR; } - /* TODO - Check for unreachable code */ - /* Maybe not - unreachable code is Mostly Harmless. */ + /* + * TODO - Check for unreachable code. Or maybe not; unreachable code is + * Mostly Harmless. + */ return TCL_OK; } @@ -2752,7 +2747,7 @@ CalculateJumpRelocations( motion = 0; for (bbPtr = assemEnvPtr->head_bb; bbPtr != NULL; - bbPtr=bbPtr->successor1) { + bbPtr = bbPtr->successor1) { /* * Advance the basic block start offset by however many bytes we * have inserted in the code up to this point @@ -2852,8 +2847,7 @@ CheckJumpTableLabels( Tcl_GetString(symbolObj)); DEBUG_PRINT(" %s -> %s (%d)\n", (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), - (valEntryPtr != NULL)); + Tcl_GetString(symbolObj), (valEntryPtr != NULL)); if (valEntryPtr == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); return TCL_ERROR; @@ -2876,6 +2870,7 @@ CheckJumpTableLabels( * *----------------------------------------------------------------------------- */ + static void ReportUndefinedLabel( AssemblyEnv* assemEnvPtr, /* Assembly environment */ @@ -2887,13 +2882,10 @@ ReportUndefinedLabel( /* Compilation environment */ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ - Tcl_Obj* result; /* Error message */ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - result = Tcl_NewStringObj("undefined label \"", -1); - Tcl_AppendObjToObj(result, jumpTarget); - Tcl_AppendToObj(result, "\"", -1); - Tcl_SetObjResult(interp, result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "undefined label \"%s\"", Tcl_GetString(jumpTarget))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", Tcl_GetString(jumpTarget), NULL); Tcl_SetErrorLine(interp, bbPtr->jumpLine); @@ -3038,8 +3030,7 @@ ResolveJumpTableTargets( auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", bbPtr, bbPtr->jumpOffset, auxDataIndex); - realJumpTablePtr = (JumptableInfo*) - envPtr->auxDataArrayPtr[auxDataIndex].clientData; + realJumpTablePtr = envPtr->auxDataArrayPtr[auxDataIndex].clientData; realJumpHashPtr = &realJumpTablePtr->hashTable; /* @@ -3147,7 +3138,6 @@ CheckNonThrowingBlock( int bound; /* Bytecode offset following the last * instruction of the block. */ unsigned char opcode; /* Current bytecode instruction */ - Tcl_Obj* retval; /* Error message */ /* * Determine where in the code array the basic block ends. @@ -3177,13 +3167,12 @@ CheckNonThrowingBlock( */ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - retval = Tcl_NewStringObj("\"", -1); - Tcl_AppendToObj(retval, tclInstructionTable[opcode].name, -1); - Tcl_AppendToObj(retval, "\" instruction may not appear in " + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" instruction may not appear in " "a context where an exception has been " - "caught and not disposed of.", -1); + "caught and not disposed of.", + tclInstructionTable[opcode].name)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL); - Tcl_SetObjResult(interp, retval); AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); } return TCL_ERROR; @@ -3216,7 +3205,7 @@ BytecodeMightThrow( */ int min = 0; - int max = sizeof(NonThrowingByteCodes)-1; + int max = sizeof(NonThrowingByteCodes) - 1; int mid; unsigned char c; @@ -3357,7 +3346,11 @@ StackCheckBasicBlock( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "inconsistent stack depths on two execution paths", -1)); - /* TODO - add execution trace of both paths */ + + /* + * TODO - add execution trace of both paths + */ + Tcl_SetErrorLine(interp, blockPtr->startLine); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); } @@ -3490,8 +3483,6 @@ StackCheckExit( int depth; /* Net stack effect */ int litIndex; /* Index in the literal pool of the empty * string */ - Tcl_Obj* depthObj; /* Net stack effect for an error message */ - Tcl_Obj* resultObj; /* Error message from this procedure */ BasicBlock* curr_bb = assemEnvPtr->curr_bb; /* Final basic block in the assembly */ @@ -3502,51 +3493,45 @@ StackCheckExit( */ if (curr_bb->flags & BB_VISITED) { - /* + /* * Exit with no operands; push an empty one. */ - depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth; - if (depth == 0) { - /* + depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth; + if (depth == 0) { + /* * Emit a 'push' of the empty literal. */ - litIndex = TclRegisterNewLiteral(envPtr, "", 0); + litIndex = TclRegisterNewLiteral(envPtr, "", 0); - /* + /* * Assumes that 'push' is at slot 0 in TalInstructionTable. */ - BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); - ++depth; - } + BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); + ++depth; + } - /* + /* * Exit with unbalanced stack. */ - if (depth != 1) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - depthObj = Tcl_NewIntObj(depth); - Tcl_IncrRefCount(depthObj); - resultObj = Tcl_NewStringObj( - "stack is unbalanced on exit from the code (depth=", - -1); - Tcl_AppendObjToObj(resultObj, depthObj); - Tcl_DecrRefCount(depthObj); - Tcl_AppendToObj(resultObj, ")", -1); - Tcl_SetObjResult(interp, resultObj); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); - } - return TCL_ERROR; - } - - /* + if (depth != 1) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "stack is unbalanced on exit from the code (depth=%d)", + depth)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + } + return TCL_ERROR; + } + + /* * Record stack usage. */ - envPtr->currStackDepth += depth; + envPtr->currStackDepth += depth; } return TCL_OK; @@ -3711,8 +3696,10 @@ ProcessCatchesInBasicBlock( jumpEnclosing = enclosing; jumpState = state; - /* TODO: Make sure that the test cases include validating - * that a natural loop can't include 'beginCatch' or 'endCatch' */ + /* + * TODO: Make sure that the test cases include validating that a natural + * loop can't include 'beginCatch' or 'endCatch' + */ if (bbPtr->flags & BB_BEGINCATCH) { /* @@ -3856,8 +3843,8 @@ BuildExceptionRanges( int catchDepth = 0; /* Current catch depth */ int maxCatchDepth = 0; /* Maximum catch depth in the program */ BasicBlock** catches; /* Stack of catches in progress */ - int* catchIndices; /* Indices of the exception ranges - * of catches in progress */ + int* catchIndices; /* Indices of the exception ranges of catches + * in progress */ int i; /* @@ -4106,7 +4093,7 @@ RestoreEmbeddedExceptionRanges( * range as reinstalled */ ExceptionRange* range; /* Current foreign exception range */ unsigned char opcode; /* Current instruction's opcode */ - int catchIndex; /* Index of the exception range to which the + int catchIndex; /* Index of the exception range to which the * current instruction refers */ int i; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c46510c..a44d736 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3645,12 +3645,8 @@ Tcl_GetMathFuncInfo( */ if (cmdPtr == NULL) { - Tcl_Obj *message; - - TclNewLiteralStringObj(message, "unknown math function \""); - Tcl_AppendToObj(message, name, -1); - Tcl_AppendToObj(message, "\"", 1); - Tcl_SetObjResult(interp, message); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown math function \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL); *numArgsPtr = -1; *argTypesPtr = NULL; diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 05ecb04..8ed6f96 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1210,7 +1210,7 @@ Tcl_GlobObjCmd( int index, i, globFlags, length, join, dir, result; char *string; const char *separators; - Tcl_Obj *typePtr, *resultPtr, *look; + Tcl_Obj *typePtr, *look; Tcl_Obj *pathOrDir = NULL; Tcl_DString prefix; static const char *const options[] = { @@ -1497,8 +1497,8 @@ Tcl_GlobObjCmd( } else { Tcl_Obj *item; - if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) && - (len == 3)) { + if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) + && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); @@ -1528,10 +1528,9 @@ Tcl_GlobObjCmd( */ badTypesArg: - TclNewObj(resultPtr); - Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1); - Tcl_AppendObjToObj(resultPtr, look); - Tcl_SetObjResult(interp, resultPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad argument to \"-types\": %s", + Tcl_GetString(look))); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); result = TCL_ERROR; join = 0; @@ -1624,6 +1623,7 @@ Tcl_GlobObjCmd( Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL); } else { const char *sep = ""; + for (i = 0; i < objc; i++) { string = Tcl_GetString(objv[i]); Tcl_AppendResult(interp, sep, string, NULL); diff --git a/generic/tclIO.c b/generic/tclIO.c index c7fab6c..78c1dc0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -2095,12 +2095,9 @@ Tcl_GetChannelHandle( chanPtr = ((Channel *) chan)->state->bottomChanPtr; if (!chanPtr->typePtr->getHandleProc) { - Tcl_Obj *err; - - TclNewLiteralStringObj(err, "channel \""); - Tcl_AppendToObj(err, Tcl_GetChannelName(chan), -1); - Tcl_AppendToObj(err, "\" does not support OS handles", -1); - Tcl_SetChannelError(chan, err); + Tcl_SetChannelError(chan, Tcl_ObjPrintf( + "channel \"%s\" does not support OS handles", + Tcl_GetChannelName(chan))); return TCL_ERROR; } result = chanPtr->typePtr->getHandleProc(chanPtr->instanceData, direction, diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 683e2e4..9ba42ef 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -605,11 +605,9 @@ TclChanCreateObjCmd( */ if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1); - Tcl_AppendObjToObj(err, resObj); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s initialize\" returned non-list: %s", + Tcl_GetString(cmdObj), Tcl_GetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -633,42 +631,37 @@ TclChanCreateObjCmd( Tcl_DecrRefCount(resObj); if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" does not support all required methods", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" does not support all required methods", + Tcl_GetString(cmdObj))); goto error; } if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" lacks a \"read\" method", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" lacks a \"read\" method", + Tcl_GetString(cmdObj))); goto error; } if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" lacks a \"write\" method", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" lacks a \"write\" method", + Tcl_GetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" supports \"cget\" but not \"cgetall\"", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" supports \"cget\" but not \"cgetall\"", + Tcl_GetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" supports \"cgetall\" but not \"cget\"", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" supports \"cgetall\" but not \"cget\"", + Tcl_GetString(cmdObj))); goto error; } diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 5bd77b7..272306b 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -601,11 +601,9 @@ TclChanPushObjCmd( */ if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1); - Tcl_AppendObjToObj(err, resObj); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s initialize\" returned non-list: %s", + Tcl_GetString(cmdObj), Tcl_GetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -629,10 +627,9 @@ TclChanPushObjCmd( Tcl_DecrRefCount(resObj); if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" does not support all required methods", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" does not support all required methods", + Tcl_GetString(cmdObj))); goto error; } @@ -652,10 +649,9 @@ TclChanPushObjCmd( } if (!mode) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" makes the channel inacessible", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" makes the channel inaccessible", + Tcl_GetString(cmdObj))); goto error; } @@ -664,18 +660,16 @@ TclChanPushObjCmd( */ if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" supports \"drain\" but not \"read\"", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" supports \"drain\" but not \"read\"", + Tcl_GetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) { - TclNewLiteralStringObj(err, "chan handler \""); - Tcl_AppendObjToObj(err, cmdObj); - Tcl_AppendToObj(err, "\" supports \"flush\" but not \"write\"", -1); - Tcl_SetObjResult(interp, err); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "chan handler \"%s\" supports \"flush\" but not \"write\"", + Tcl_GetString(cmdObj))); goto error; } diff --git a/generic/tclObj.c b/generic/tclObj.c index a1316d9..099b67d 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2763,12 +2763,9 @@ Tcl_GetLongFromObj( #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_Obj *msg; - - TclNewLiteralStringObj(msg, "expected integer but got \""); - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -3067,12 +3064,9 @@ Tcl_GetWideIntFromObj( } if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_Obj *msg; - - TclNewLiteralStringObj(msg, "expected integer but got \""); - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -3401,12 +3395,9 @@ GetBignumFromObj( #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_Obj *msg; - - TclNewLiteralStringObj(msg, "expected integer but got \""); - Tcl_AppendObjToObj(msg, objPtr); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; diff --git a/generic/tclProc.c b/generic/tclProc.c index 48f472f..50cf0f7 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2480,7 +2480,7 @@ SetLambdaFromAny( { Interp *iPtr = (Interp *) interp; const char *name; - Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; + Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; int objc, result; Proc *procPtr; @@ -2495,10 +2495,9 @@ SetLambdaFromAny( result = TclListObjGetElements(NULL, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { - TclNewLiteralStringObj(errPtr, "can't interpret \""); - Tcl_AppendObjToObj(errPtr, objPtr); - Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); - Tcl_SetObjResult(interp, errPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't interpret \"%s\" as a lambda expression", + Tcl_GetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); return TCL_ERROR; } diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 15bff3e..8a961ff 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1384,11 +1384,9 @@ TclParseNumber( if (status != TCL_OK) { if (interp != NULL) { - Tcl_Obj *msg; + Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"", + expected); - TclNewLiteralStringObj(msg, "expected "); - Tcl_AppendToObj(msg, expected, -1); - Tcl_AppendToObj(msg, " but got \"", -1); Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); Tcl_AppendToObj(msg, "\"", -1); if (state == BAD_OCTAL) { diff --git a/generic/tclVar.c b/generic/tclVar.c index 55c031c..62bf1c4 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -1826,6 +1826,7 @@ TclPtrSetVar( Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; int result; + int cleanupOnEarlyError = (newValuePtr->refCount == 0); /* * If the variable is in a hashtable and its hPtr field is NULL, then we @@ -1997,7 +1998,7 @@ TclPtrSetVar( return resultPtr; earlyError: - if (newValuePtr->refCount == 0) { + if (cleanupOnEarlyError) { Tcl_DecrRefCount(newValuePtr); } goto cleanup; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 3ddc3fb..922ec18 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2253,7 +2253,16 @@ ZlibTransformClose( ZlibChannelData *cd = instanceData; int e, result = TCL_OK; + /* + * Delete the support timer. + */ + ZlibTransformTimerKill(cd); + + /* + * Flush any data waiting to be compressed. + */ + if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { cd->outStream.avail_in = 0; do { @@ -2286,11 +2295,15 @@ ZlibTransformClose( } } } while (e != Z_STREAM_END); - e = deflateEnd(&cd->inStream); + e = deflateEnd(&cd->outStream); } else { - e = inflateEnd(&cd->outStream); + e = inflateEnd(&cd->inStream); } + /* + * Release all memory. + */ + if (cd->inBuffer) { ckfree(cd->inBuffer); cd->inBuffer = NULL; @@ -2299,6 +2312,7 @@ ZlibTransformClose( ckfree(cd->outBuffer); cd->outBuffer = NULL; } + ckfree(cd); return result; } diff --git a/library/init.tcl b/library/init.tcl index f1d6a64..685fc7b 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -15,7 +15,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.6b1.2 +package require -exact Tcl 8.6b2 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 3ea017b..d8defcc 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -207,7 +207,7 @@ test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler misma } -returnCodes error -cleanup { tempdone rename foo {} -} -match glob -result {*makes the channel inacessible} +} -match glob -result {*makes the channel inaccessible} # iortrans-2.15 event/watch methods elimimated, removed these tests. # iortrans-2.16 test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body { diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in index e2a636d..653b1e1 100644 --- a/tools/tcl.wse.in +++ b/tools/tcl.wse.in @@ -12,7 +12,7 @@ item: Global Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 - Disk Label=tcl8.6b1 + Disk Label=tcl8.6b2 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 diff --git a/unix/configure b/unix/configure index 53f44ac..72d704d 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="b1.2" +TCL_PATCH_LEVEL="b2" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 34908a7..35eb3e5 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="b1.2" +TCL_PATCH_LEVEL="b2" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index 3331b14..b35e220 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6b1 +Version: 8.6b2 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index 180901c..3a40da1 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="b1.2" +TCL_PATCH_LEVEL="b2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 diff --git a/win/configure.in b/win/configure.in index 7d43a38..cb958f2 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="b1.2" +TCL_PATCH_LEVEL="b2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 |