[47ac84309b] Import of aspect's branch from his personal repository on chiselapp.aspect_lreplace_cleanup

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}