From de32d87523a41ddce8083b538b597f38126d4bbc Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Aug 2011 13:16:22 +0000 Subject: [Bug 3384840]: Fix memory leaks in the assembler due to Tcl_Obj reference ownership error. FossilOrigin-Name: a8ffe21e9271ab6b0ffab29939887e98e655b5e4 --- ChangeLog | 10 +++++++ generic/tclAssembly.c | 22 +++----------- tests/assemble.test | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 96 insertions(+), 18 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3e3bbec..e6bf629 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2011-08-04 Donal K. Fellows + + * generic/tclAssembly.c (AssembleOneLine, GetBooleanOperand) + (GetIntegerOperand, GetListIndexOperand, FindLocalVar): [Bug 3384840]: + A Tcl_Obj is allocated by GetNextOperand, so callers of it must not + hold a reference to one in the 'out' parameter when calling it. This + was causing a great many memory leaks. + * tests/assemble.test (assemble-51.*): Added group of memory leak + tests. + 2011-08-02 Don Porter * changes: Updates for 8.6b2 release. diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 1b87886..e12d0f8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1244,8 +1244,6 @@ AssembleOneLine( */ tokenPtr = parsePtr->tokenPtr; - instNameObj = Tcl_NewObj(); - Tcl_IncrRefCount(instNameObj); if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) { return TCL_ERROR; } @@ -2087,17 +2085,14 @@ GetBooleanOperand( Tcl_Token* tokenPtr = *tokenPtrPtr; /* INOUT: Pointer to the next token in the * source code */ - Tcl_Obj* intObj = Tcl_NewObj(); - /* Integer from the source code */ + Tcl_Obj* intObj; /* Integer from the source code */ int status; /* Tcl status return */ /* * Extract the next token as a string. */ - Tcl_IncrRefCount(intObj); if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - Tcl_DecrRefCount(intObj); return TCL_ERROR; } @@ -2143,17 +2138,14 @@ GetIntegerOperand( Tcl_Token* tokenPtr = *tokenPtrPtr; /* INOUT: Pointer to the next token in the * source code */ - Tcl_Obj* intObj = Tcl_NewObj(); - /* Integer from the source code */ + Tcl_Obj* intObj; /* Integer from the source code */ int status; /* Tcl status return */ /* * Extract the next token as a string. */ - Tcl_IncrRefCount(intObj); if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - Tcl_DecrRefCount(intObj); return TCL_ERROR; } @@ -2199,17 +2191,14 @@ GetListIndexOperand( Tcl_Token* tokenPtr = *tokenPtrPtr; /* INOUT: Pointer to the next token in the * source code */ - Tcl_Obj* intObj = Tcl_NewObj(); - /* Integer from the source code */ + Tcl_Obj* intObj; /* Integer from the source code */ int status; /* Tcl status return */ /* * Extract the next token as a string. */ - Tcl_IncrRefCount(intObj); if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - Tcl_DecrRefCount(intObj); return TCL_ERROR; } @@ -2256,15 +2245,12 @@ FindLocalVar( Tcl_Token* tokenPtr = *tokenPtrPtr; /* INOUT: Pointer to the next token * in the source code */ - Tcl_Obj* varNameObj = Tcl_NewObj(); - /* Name of the variable */ + Tcl_Obj* varNameObj; /* Name of the variable */ const char* varNameStr; int varNameLen; int localVar; /* Index of the variable in the LVT */ - Tcl_IncrRefCount(varNameObj); if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { - Tcl_DecrRefCount(varNameObj); return -1; } varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); diff --git a/tests/assemble.test b/tests/assemble.test index dae4821..7d4e5d1 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -30,6 +30,23 @@ proc fillTables {} { } return $s } + +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} # assemble-1 - TclNRAssembleObjCmd @@ -3198,6 +3215,71 @@ test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { } -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88} } + +test assemble-51.1 {memory leak testing} memory { + leaktest { + apply {{} {assemble {push hello}}} + } +} 0 +test assemble-51.2 {memory leak testing} memory { + leaktest { + apply {{{x 0}} {assemble {incrImm x 1}}} + } +} 0 +test assemble-51.3 {memory leak testing} memory { + leaktest { + apply {{n} { + assemble { + load n; # max + dup; # max n + jump start; # max n + + label loop; # max n + over 1; # max n max + over 1; # max in max n + ge; # man n max>=n + jumpTrue skip; # max n + + reverse 2; # n max + pop; # n + dup; # n n + + label skip; # max n + dup; # max n n + push 2; # max n n 2 + mod; # max n n%2 + jumpTrue odd; # max n + + push 2; # max n 2 + div; # max n/2 -> max n + jump start; # max n + + label odd; # max n + push 3; # max n 3 + mult; # max 3*n + push 1; # max 3*n 1 + add; # max 3*n+1 + + label start; # max n + dup; # max n n + push 1; # max n n 1 + neq; # max n n>1 + jumpTrue loop; # max n + + pop; # max + } + }} 1 + } +} 0 +test assemble-51.4 {memory leak testing} memory { + leaktest { + catch { + apply {{} { + assemble {reverse polish notation} + }} + } + } +} 0 rename fillTables {} rename assemble {} -- cgit v0.12 From afb51818ad6a9e10a9d71ef8037b445513ef7159 Mon Sep 17 00:00:00 2001 From: max Date: Thu, 4 Aug 2011 14:03:59 +0000 Subject: Don't use AI_ADDRCONFIG for now. It seems to do more harm than good. FossilOrigin-Name: 585e304a31f48559df5f6dc5de7870c441b0fdf9 --- ChangeLog | 12 ++++++++++++ generic/tclIOSock.c | 9 +++++++++ 2 files changed, 21 insertions(+) diff --git a/ChangeLog b/ChangeLog index e6bf629..7d4e098 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +<<<<<<< BEGIN MERGE CONFLICT: local copy shown first <<<<<<<<<<<<<<< +2011-08-04 Reinhard Max + + * generic/tclIOSock.c (TclCreateSocketAddress): Don't bother using + AI_ADDRCONFIG for now, as it was causing problems in various + situations. + +2011-08-02 Don Porter +======= COMMON ANCESTOR content follows ============================ +2011-08-02 Don Porter +======= MERGED IN content follows ================================== 2011-08-04 Donal K. Fellows * generic/tclAssembly.c (AssembleOneLine, GetBooleanOperand) @@ -9,6 +20,7 @@ tests. 2011-08-02 Don Porter +>>>>>>> END MERGE CONFLICT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> * changes: Updates for 8.6b2 release. * tools/tcltk-man2html.tcl: Variable substitution botch. diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index aabd67d..768428f 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -178,6 +178,14 @@ TclCreateSocketAddress( } hints.ai_socktype = SOCK_STREAM; +#if 0 + /* + * We found some problems when using AI_ADDRCONFIG, e.g. on systems that + * have no networking besides the loopback interface and want to resolve + * localhost. See bugs 3385024, 3382419, 3382431. As the advantage of + * using AI_ADDRCONFIG in situations where it works, is probably low, + * we'll leave it out for now. After all, it is just an optimisation. + */ #if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux) /* * Missing on: OpenBSD, NetBSD. @@ -185,6 +193,7 @@ TclCreateSocketAddress( */ hints.ai_flags |= AI_ADDRCONFIG; #endif +#endif if (willBind) { hints.ai_flags |= AI_PASSIVE; } -- cgit v0.12 From 8ad9973008c5382fedb89dc6ddcef622b08454dc Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Aug 2011 14:13:33 +0000 Subject: More memleak plugging. FossilOrigin-Name: 979817386778903c3b43a66b2b1ecba2d706faaa --- ChangeLog | 14 +++++++------- generic/tclAssembly.c | 17 ++--------------- 2 files changed, 9 insertions(+), 22 deletions(-) diff --git a/ChangeLog b/ChangeLog index 7d4e098..38914cf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,14 +1,15 @@ -<<<<<<< BEGIN MERGE CONFLICT: local copy shown first <<<<<<<<<<<<<<< +2011-08-04 Donal K. Fellows + + * 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 Reinhard Max * generic/tclIOSock.c (TclCreateSocketAddress): Don't bother using AI_ADDRCONFIG for now, as it was causing problems in various situations. - -2011-08-02 Don Porter -======= COMMON ANCESTOR content follows ============================ -2011-08-02 Don Porter -======= MERGED IN content follows ================================== + 2011-08-04 Donal K. Fellows * generic/tclAssembly.c (AssembleOneLine, GetBooleanOperand) @@ -20,7 +21,6 @@ tests. 2011-08-02 Don Porter ->>>>>>> END MERGE CONFLICT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> * changes: Updates for 8.6b2 release. * tools/tcltk-man2html.tcl: Variable substitution botch. diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index e12d0f8..7868882 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1173,24 +1173,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); } @@ -2255,6 +2241,7 @@ FindLocalVar( } varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { + Tcl_DecrRefCount(varNameObj); return -1; } localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); -- cgit v0.12 From 7f1207165a699b074e472df039cc7462ccac80aa Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 4 Aug 2011 14:38:09 +0000 Subject: missing TIP id in changes FossilOrigin-Name: ce6e82ac1b3570ba9514d3cb6084117510297436 --- changes | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/changes b/changes index 76ed3e8..f364e1c 100644 --- a/changes +++ b/changes @@ -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) @@ -7726,7 +7726,7 @@ memory with buffer backup (ferrieux) 2010-03-20 (enhancement) permit [fcopy] of > 2**31 bytes (fellows) -2010-03-24 (new feature) [info object methodtype] (fellows) +2010-03-24 (new feature)[TIP 354] [info object methodtype] (fellows) 2010-03-24 (bug fix)[2383005] [return -errorcode] reject non-list (porter) -- cgit v0.12 From e1069f94a00106fe3d5e067507af1bc649150728 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 4 Aug 2011 16:35:52 +0000 Subject: More changes tidying. FossilOrigin-Name: 3fbc04d14bf532557aeb6fef23df0caa1e151e6a --- changes | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/changes b/changes index f364e1c..434750c 100644 --- a/changes +++ b/changes @@ -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 @@ -7726,7 +7726,7 @@ memory with buffer backup (ferrieux) 2010-03-20 (enhancement) permit [fcopy] of > 2**31 bytes (fellows) -2010-03-24 (new feature)[TIP 354] [info object methodtype] (fellows) +2010-03-24 (new feature) [info object methodtype] (fellows) 2010-03-24 (bug fix)[2383005] [return -errorcode] reject non-list (porter) -- cgit v0.12 From 52f5d8ac663146901f02376f83c2b96fa3b6bc13 Mon Sep 17 00:00:00 2001 From: mig Date: Thu, 4 Aug 2011 18:40:05 +0000 Subject: * generic/tclVar.c (TclPtrSetVar): fix valgrind-detected error when newValuePtr is the interp's result obj. FossilOrigin-Name: 8c944e4622758e32da6501e20a87f9165b138199 --- ChangeLog | 5 +++++ generic/tclVar.c | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 38914cf..13f8a69 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-08-04 Miguel Sofer + + * generic/tclVar.c (TclPtrSetVar): fix valgrind-detected error + when newValuePtr is the interp's result obj. + 2011-08-04 Donal K. Fellows * generic/tclAssembly.c (FreeAssemblyEnv): [Bug 3384840]: Plug another 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; -- cgit v0.12 From d2425b31ef160cbabc59c462b0506f29175dd2fb Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 4 Aug 2011 23:12:30 +0000 Subject: [Bug 3386197]: Plug memory leak in unstacking of zlib transforms. FossilOrigin-Name: 89ff730dfa2e144ceff4b4fe847659226bfc4b02 --- ChangeLog | 13 +++++++++---- generic/tclZlib.c | 14 ++++++++++++++ 2 files changed, 23 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 13f8a69..61825c0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,8 +1,13 @@ +2011-08-05 Donal K. Fellows + + * generic/tclZlib.c (ZlibTransformClose): [Bug 3386197]: Plug a memory + leak found by Miguel with valgrind. + 2011-08-04 Miguel Sofer - * generic/tclVar.c (TclPtrSetVar): fix valgrind-detected error - when newValuePtr is the interp's result obj. - + * generic/tclVar.c (TclPtrSetVar): Fix valgrind-detected error when + newValuePtr is the interp's result obj. + 2011-08-04 Donal K. Fellows * generic/tclAssembly.c (FreeAssemblyEnv): [Bug 3384840]: Plug another @@ -149,7 +154,7 @@ 2011-07-07 Miguel Sofer - * generic/tclBasic.c: add missing INT2PTR + * generic/tclBasic.c: Add missing INT2PTR 2011-07-03 Donal K. Fellows diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 3ddc3fb..80431a3 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 { @@ -2291,6 +2300,10 @@ ZlibTransformClose( e = inflateEnd(&cd->outStream); } + /* + * 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; } -- cgit v0.12 From 770d8b9b58647e579193cb2fb694aa086df8ecb1 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 5 Aug 2011 00:00:15 +0000 Subject: [Bug 3386197]: Fix buffer direction botch. Damn you, confusing terminology! FossilOrigin-Name: d104ee18f9506fe21f0dfce6f391c03325a852b1 --- ChangeLog | 3 ++- generic/tclZlib.c | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index 61825c0..9d2b16d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,8 @@ 2011-08-05 Donal K. Fellows * generic/tclZlib.c (ZlibTransformClose): [Bug 3386197]: Plug a memory - leak found by Miguel with valgrind. + leak found by Miguel with valgrind, and ensure that the correct + direction's buffers are released. 2011-08-04 Miguel Sofer diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 80431a3..922ec18 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2295,9 +2295,9 @@ ZlibTransformClose( } } } while (e != Z_STREAM_END); - e = deflateEnd(&cd->inStream); + e = deflateEnd(&cd->outStream); } else { - e = inflateEnd(&cd->outStream); + e = inflateEnd(&cd->inStream); } /* -- cgit v0.12 From 554fbb470ddd7e74a4f53ec86e385ef6551c31ae Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 5 Aug 2011 09:36:48 +0000 Subject: Ensure that memory isn't leaked when an unknown instruction is encountered. FossilOrigin-Name: d4980ede3ebb3babf9c85b61d3baf89183399f6e --- ChangeLog | 4 + generic/tclAssembly.c | 219 +++++++++++++++++++++++++------------------------- 2 files changed, 115 insertions(+), 108 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9d2b16d..c233e6d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,9 @@ 2011-08-05 Donal K. Fellows + * 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. diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7868882..eca934f 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 */ @@ -1208,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 */ @@ -1241,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; } /* @@ -1310,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); @@ -1349,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); @@ -1363,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); @@ -1558,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); @@ -1569,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); @@ -1581,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; @@ -1596,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); @@ -1658,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); @@ -1673,9 +1690,7 @@ AssembleOneLine( status = TCL_OK; cleanup: - if (instNameObj) { - Tcl_DecrRefCount(instNameObj); - } + Tcl_DecrRefCount(instNameObj); if (operand1Obj) { Tcl_DecrRefCount(operand1Obj); } @@ -1857,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, @@ -1904,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) { @@ -1940,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"); @@ -2229,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; @@ -2282,6 +2294,7 @@ CheckNamespaceQualifiers( { 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); @@ -2458,7 +2471,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! */ @@ -2474,14 +2486,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; } @@ -2518,7 +2527,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; /* @@ -2680,8 +2689,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; } @@ -2739,7 +2750,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 @@ -2839,8 +2850,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; @@ -2863,6 +2873,7 @@ CheckJumpTableLabels( * *----------------------------------------------------------------------------- */ + static void ReportUndefinedLabel( AssemblyEnv* assemEnvPtr, /* Assembly environment */ @@ -2874,13 +2885,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); @@ -3025,8 +3033,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; /* @@ -3134,7 +3141,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. @@ -3164,13 +3170,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; @@ -3203,7 +3208,7 @@ BytecodeMightThrow( */ int min = 0; - int max = sizeof(NonThrowingByteCodes)-1; + int max = sizeof(NonThrowingByteCodes) - 1; int mid; unsigned char c; @@ -3344,7 +3349,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); } @@ -3477,8 +3486,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 */ @@ -3489,51 +3496,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; @@ -3698,8 +3699,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) { /* @@ -3843,8 +3846,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; /* @@ -4093,7 +4096,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; -- cgit v0.12 From df3413fbe67d7a2c1a714d8c3bd0409ba248cd2c Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 5 Aug 2011 15:23:55 +0000 Subject: Use Tcl_PrintfObj to generate more (complex) error messages. FossilOrigin-Name: 76495bbc296be2fade58782570e8a9ae5b98dc11 --- generic/tclAssembly.c | 7 ++----- generic/tclBasic.c | 8 ++------ generic/tclFileName.c | 14 +++++++------- generic/tclIO.c | 9 +++------ generic/tclIORChan.c | 43 ++++++++++++++++++------------------------- generic/tclIORTrans.c | 36 +++++++++++++++--------------------- generic/tclObj.c | 27 +++++++++------------------ generic/tclProc.c | 9 ++++----- generic/tclStrToD.c | 6 ++---- tests/ioTrans.test | 2 +- 10 files changed, 63 insertions(+), 98 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index eca934f..f45ae07 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -2292,15 +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; } 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/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 { -- cgit v0.12