Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -2753,11 +2753,11 @@ * list length. This won't ever trigger for the "end-*" case as that will * be properly constrained by TclGetIntForIndex because we use listLen-1 * (to allow for replacing the last elem). */ - if ((first >= listLen) && (listLen > 0)) { + if ((first > listLen) && (listLen > 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list doesn't contain element %s", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX", NULL); return TCL_ERROR; Index: generic/tclCompCmdsGR.c ================================================================== --- generic/tclCompCmdsGR.c +++ generic/tclCompCmdsGR.c @@ -1486,10 +1486,19 @@ tokenPtr = TokenAfter(tokenPtr); if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { return TCL_ERROR; } + /* + * idx1, idx2 are now in canonical form: + * + * - integer: [0,len+1] + * - end index: INDEX_END + * - -ive offset: INDEX_END-[len-1,0] + * - +ive offset: INDEX_END+1 + */ + /* * Compilation fails when one index is end-based but the other isn't. * Fixing this will require more bytecodes, but this is a workaround for * now. [Bug 47ac84309b] */ @@ -1519,10 +1528,13 @@ } else if (idx2 == INDEX_END) { idx2 = idx1 - 1; idx1 = 0; goto dropEnd; } else { + if (idx2 < idx1) { + idx2 = idx1 - 1; + } if (idx1 > 0) { tmpObj = Tcl_NewIntObj(idx1); Tcl_IncrRefCount(tmpObj); } goto dropRange; @@ -1546,13 +1558,11 @@ } else if (idx2 == INDEX_END) { idx2 = idx1 - 1; idx1 = 0; goto replaceTail; } else { - if (idx1 > 0 && idx2 > 0 && idx2 < idx1) { - idx2 = idx1 - 1; - } else if (idx1 < 0 && idx2 < 0 && idx2 < idx1) { + if (idx2 < idx1) { idx2 = idx1 - 1; } if (idx1 > 0) { tmpObj = Tcl_NewIntObj(idx1); Tcl_IncrRefCount(tmpObj); @@ -1564,11 +1574,11 @@ * Issue instructions to perform the operations relating to configurations * that just drop. The only argument pushed on the stack is the list to * operate on. */ - dropAll: + dropAll: /* This just ensures the arg is a list. */ TclEmitOpcode( INST_LIST_LENGTH, envPtr); TclEmitOpcode( INST_POP, envPtr); PushStringLiteral(envPtr, ""); goto done; @@ -1577,16 +1587,25 @@ TclEmitInt4( idx2, envPtr); goto done; dropRange: if (tmpObj != NULL) { + /* + * Emit bytecode to check the list length. + */ + TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); - TclEmitOpcode( INST_GT, envPtr); + TclEmitOpcode( INST_GE, envPtr); offset = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + + /* + * Emit an error if we've been given an empty list. + */ + TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); offset2 = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( @@ -1633,20 +1652,34 @@ TclEmitOpcode( INST_LIST_CONCAT, envPtr); goto done; replaceRange: if (tmpObj != NULL) { + /* + * Emit bytecode to check the list length. + */ + TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); + + /* + * Check the list length vs idx1. + */ + TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); - TclEmitOpcode( INST_GT, envPtr); + TclEmitOpcode( INST_GE, envPtr); offset = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + + /* + * Emit an error if we've been given an empty list. + */ + TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); offset2 = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, 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, Index: tests/lreplace.test ================================================================== --- tests/lreplace.test +++ tests/lreplace.test @@ -96,11 +96,16 @@ set foo {a b} list [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] } {a {} {}} - +test lreplace-1.27 {lreplace command} { + lreplace x 1 1 +} x +test lreplace-1.28 {lreplace command} { + lreplace x 1 1 y +} {x y} test lreplace-2.1 {lreplace errors} { list [catch lreplace msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element ...?"}} test lreplace-2.2 {lreplace errors} { @@ -117,12 +122,12 @@ } {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.6 {lreplace errors} { list [catch {lreplace x 3 2} msg] $msg } {1 {list doesn't contain element 3}} test lreplace-2.7 {lreplace errors} { - list [catch {lreplace x 1 1} msg] $msg -} {1 {list doesn't contain element 1}} + list [catch {lreplace x 2 2} msg] $msg +} {1 {list doesn't contain element 2}} test lreplace-3.1 {lreplace won't modify shared argument objects} { proc p {} { lreplace "a b c" 1 1 "x y" return "a b c" @@ -179,10 +184,16 @@ lreplace {0 1 2 3 4} end-2 1 a b c } {0 1 a b c 2 3 4} test lreplace-4.12 {lreplace end index first} { lreplace {0 1 2 3 4} end-2 2 a b c } {0 1 a b c 3 4} +test lreplace-4.13 {lreplace empty list} { + lreplace {} 1 1 1 +} 1 +test lreplace-4.14 {lreplace empty list} { + lreplace {} 2 2 2 +} 2 test lreplace-5.1 {compiled lreplace: Bug 47ac84309b} { apply {x { lreplace $x end 0 }} {a b c} @@ -190,14 +201,40 @@ test lreplace-5.2 {compiled lreplace: Bug 47ac84309b} { apply {x { lreplace $x end 0 A }} {a b c} } {a b A c} + +# Testing for compiled behaviour. Far too many variations to check with +# spelt-out tests. Note that this *just* checks whether the compiled version +# and the interpreted version are the same, not whether the interpreted +# version is correct. +apply {{} { + set lss {{} {a} {a b c} {a b c d}} + set ins {{} A {A B}} + set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} + set lreplace lreplace + + foreach ls $lss { + foreach a $idxs { + foreach b $idxs { + foreach i $ins { + set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m] + set tester [list lreplace $ls $a $b {*}$i] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lreplace-6.[incr n] {lreplace battery} \ + [list apply [list {} $script]] $expected + } + } + } + } +}} # cleanup catch {unset foo} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: