summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2016-03-30 08:46:43 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2016-03-30 08:46:43 (GMT)
commitdedc1d86a28c562377215bc2d0bf10e75ed00f1d (patch)
tree467dbf26f505d4f42a10c904b24b552022631320
parente586c259bcbae989eca56b696377488dfe656b20 (diff)
downloadtcl-dedc1d86a28c562377215bc2d0bf10e75ed00f1d.zip
tcl-dedc1d86a28c562377215bc2d0bf10e75ed00f1d.tar.gz
tcl-dedc1d86a28c562377215bc2d0bf10e75ed00f1d.tar.bz2
[47ac84309b] Import of aspect's branch from his personal repository on chiselapp.aspect_lreplace_cleanup
-rw-r--r--generic/tclCmdIL.c2
-rw-r--r--generic/tclCompCmdsGR.c47
-rw-r--r--tests/lreplace.test43
3 files changed, 81 insertions, 11 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 739dca9..0d35397 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2755,7 +2755,7 @@ Tcl_LreplaceObjCmd(
* (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",
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 9f430ea..ffe39ba 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -1489,6 +1489,15 @@ TclCompileLreplaceCmd(
}
/*
+ * 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]
@@ -1521,6 +1530,9 @@ TclCompileLreplaceCmd(
idx1 = 0;
goto dropEnd;
} else {
+ if (idx2 < idx1) {
+ idx2 = idx1 - 1;
+ }
if (idx1 > 0) {
tmpObj = Tcl_NewIntObj(idx1);
Tcl_IncrRefCount(tmpObj);
@@ -1548,9 +1560,7 @@ TclCompileLreplaceCmd(
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) {
@@ -1566,7 +1576,7 @@ TclCompileLreplaceCmd(
* operate on.
*/
- dropAll:
+ dropAll: /* This just ensures the arg is a list. */
TclEmitOpcode( INST_LIST_LENGTH, envPtr);
TclEmitOpcode( INST_POP, envPtr);
PushStringLiteral(envPtr, "");
@@ -1579,12 +1589,21 @@ TclCompileLreplaceCmd(
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);
@@ -1635,16 +1654,30 @@ TclCompileLreplaceCmd(
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,
diff --git a/tests/lreplace.test b/tests/lreplace.test
index 55a36a8..d7f8226 100644
--- a/tests/lreplace.test
+++ b/tests/lreplace.test
@@ -98,7 +98,12 @@ test lreplace-1.26 {lreplace command} {
[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
@@ -119,8 +124,8 @@ 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 {} {
@@ -181,6 +186,12 @@ test lreplace-4.11 {lreplace end index first} {
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 {
@@ -192,6 +203,32 @@ test lreplace-5.2 {compiled lreplace: Bug 47ac84309b} {
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}