Tcl Source Code

Changes On Branch tip-505
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch tip-505 Excluding Merge-Ins

This is equivalent to a diff from 019ea86cdd to 61f5b23d57

2018-09-27
08:19
Implementation of TIP 505: Make [lreplace] Accept All Out-of-Range Index Values check-in: 125e27afcc user: dkf tags: core-8-6-branch
07:44
Updated documentation Closed-Leaf check-in: 61f5b23d57 user: dkf tags: tip-505
2018-09-20
13:41
merge bug-46b6edad51-concurrent-http check-in: 0d794ec27b user: kjnash tags: core-8-6-branch
2018-09-15
18:41
merge 8.6 Leaf check-in: 82cbd9d626 user: kjnash tags: bug-46b6edad51-concurrent-http
2018-09-10
15:28
Rebase TIP 505 implementation a patch for 8.6. check-in: 998387f679 user: dgp tags: tip-505
2018-09-07
22:23
Merge 8.6 check-in: 4ccc3b6902 user: jan.nijtmans tags: core-8-branch
14:24
small code review (duplicate code removed) check-in: 019ea86cdd user: sebres tags: core-8-6-branch
12:04
Added test for [631b4c45df]. check-in: 036c01e552 user: dgp tags: core-8-6-branch

Changes to doc/lreplace.n.

26
27
28
29
30
31
32






33
34
35
36
37
38
39







40
41
42
43
44
45
46
..
74
75
76
77
78
79
80













81
82
83
84
85
86




supporting simple index arithmetic and indices relative to the
end of the list.
0 refers to the first element of the
list, and \fBend\fR refers to the last element of the list.
If \fIlist\fR is empty, then \fIfirst\fR and \fIlast\fR are ignored.
.PP
If \fIfirst\fR is less than zero, it is considered to refer to before the






first element of the list.  For non-empty lists, the element indicated
by \fIfirst\fR must exist or \fIfirst\fR must indicate before the
start of the list.
.PP
If \fIlast\fR is less than \fIfirst\fR, then any specified elements
will be inserted into the list before the point specified by \fIfirst\fR
with no elements being deleted.







.PP
The \fIelement\fR arguments specify zero or more new arguments to
be added to the list in place of those that were deleted.
Each \fIelement\fR argument will become a separate element of
the list.  If no \fIelement\fR arguments are specified, then the elements
between \fIfirst\fR and \fIlast\fR are simply deleted.  If \fIlist\fR
is empty, any \fIelement\fR arguments are added to the end of the list.
................................................................................
.CS
proc lremove {listVariable value} {
    upvar 1 $listVariable var
    set idx [lsearch -exact $var $value]
    set var [\fBlreplace\fR $var $idx $idx]
}
.CE













.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lrange(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, replace










>
>
>
>
>
>
|
|





>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>






>
>
>
>
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
..
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
supporting simple index arithmetic and indices relative to the
end of the list.
0 refers to the first element of the
list, and \fBend\fR refers to the last element of the list.
If \fIlist\fR is empty, then \fIfirst\fR and \fIlast\fR are ignored.
.PP
If \fIfirst\fR is less than zero, it is considered to refer to before the
first element of the list.
.VS TIP505
If \fIfirst\fR indicates a position greater than the index of the last element
of the list, it is treated as if it is an index one greater than the last
element. This allows this command to append elements to the list.
.VE TIP505
For non-empty lists, the element indicated
by \fIfirst\fR must exist, or \fIfirst\fR must indicate before the
start of the list.
.PP
If \fIlast\fR is less than \fIfirst\fR, then any specified elements
will be inserted into the list before the point specified by \fIfirst\fR
with no elements being deleted.
.VS TIP505
If \fIlast\fR is greater than the index of the last item of the list, it is
treated as if it is an index one greater than the last element. This means
that if it is also greater than than \fIfirst\fR, all elements from
\fIfirst\fR to the end of the list will be replaced, and otherwise the
elements will be appended.
.VE TIP505
.PP
The \fIelement\fR arguments specify zero or more new arguments to
be added to the list in place of those that were deleted.
Each \fIelement\fR argument will become a separate element of
the list.  If no \fIelement\fR arguments are specified, then the elements
between \fIfirst\fR and \fIlast\fR are simply deleted.  If \fIlist\fR
is empty, any \fIelement\fR arguments are added to the end of the list.
................................................................................
.CS
proc lremove {listVariable value} {
    upvar 1 $listVariable var
    set idx [lsearch -exact $var $value]
    set var [\fBlreplace\fR $var $idx $idx]
}
.CE
.PP
.VS TIP505
Adding elements to the end of the list; note that \fBend+2\fR will initially
be treated as if it is \fB6\fR here, but both that and \fB12345\fR are greater
than the index of the final item so they behave identically:
.PP
.CS
% set var {a b c d e}
a b c d e
% set var [\fBlreplace\fR $var 12345 end+2 f g h i]
a b c d e f g h i
.CE
.VE TIP505
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lrange(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, replace
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:

Changes to generic/tclCmdIL.c.

2743
2744
2745
2746
2747
2748
2749


2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
    if (result != TCL_OK) {
	return result;
    }

    if (first < 0) {
	first = 0;
    }



    /*
     * Complain if the user asked for a start element that is greater than the
     * 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)) {
	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;
    }
    if (last >= listLen) {
	last = listLen - 1;
    }
    if (first <= last) {
	numToDelete = last - first + 1;
    } else {
	numToDelete = 0;






>
>
|
<
<
<
<
<
<

<
<
<
<
<
<
<







2743
2744
2745
2746
2747
2748
2749
2750
2751
2752






2753







2754
2755
2756
2757
2758
2759
2760
    if (result != TCL_OK) {
	return result;
    }

    if (first < 0) {
	first = 0;
    }
    if (first > listLen) {
	first = listLen;
    }














    if (last >= listLen) {
	last = listLen - 1;
    }
    if (first <= last) {
	numToDelete = last - first + 1;
    } else {
	numToDelete = 0;

Changes to generic/tclCompCmdsGR.c.

1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
....
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522


1523
1524
1525
1526
1527
1528
1529
1530
....
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
				 * command. */
    Command *cmdPtr,		/* Points to defintion of command being
				 * compiled. */
    CompileEnv *envPtr)		/* Holds the resulting instructions. */
{
    Tcl_Token *tokenPtr, *listTokenPtr;
    DefineLineInformation;	/* TIP #280 */
    int idx1, idx2, i, offset, offset2;
    int emptyPrefix=1, suffixStart = 0;

    if (parsePtr->numWords < 4) {
	return TCL_ERROR;
    }
    listTokenPtr = TokenAfter(parsePtr->tokenPtr);

................................................................................

    tokenPtr = TokenAfter(tokenPtr);
    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
	    &idx2) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * idx1, idx2 are the conventional encoded forms of the tokens parsed
     * as all forms of index values.  Values of idx1 that come before the
     * list are treated the same as if they were the start of the list.
     * Values of idx2 that come after the list are treated the same as if
     * they were the end of the list.
     */

    if (idx1 == TCL_INDEX_AFTER) {
	/*
	 * [lreplace] treats idx1 value end+1 differently from end+2, etc.
	 * The operand encoding cannot distinguish them, so we must bail
	 * out to direct evaluation.
	 */
	return TCL_ERROR;
    }

    /*
     * General structure of the [lreplace] result is
     *		prefix replacement suffix
     * In a few cases we can predict various parts will be empty and
     * take advantage.
     *
     * The proper suffix begins with the greater of indices idx1 or
     * idx2 + 1. If we cannot tell at compile time which is greater,
     * we must defer to direct evaluation.
     */



    if (idx2 == TCL_INDEX_BEFORE) {
	suffixStart = idx1;
    } else if (idx2 == TCL_INDEX_END) {
	suffixStart = TCL_INDEX_AFTER;
    } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END))
	    || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) {
	suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
    } else {
................................................................................

	/* Make a list of them... */
	TclEmitInstInt4(	INST_LIST, i - 4,		envPtr);

	emptyPrefix = 0;
    }
     
    /*
     * [lreplace] raises an error when idx1 points after the list, but
     * only when the list is not empty. This is maximum stupidity.
     *
     * TODO: TIP this nonsense away!
     */
    if (idx1 >= TCL_INDEX_START) {
	if (emptyPrefix) {
	    TclEmitOpcode(	INST_DUP,			envPtr);
	} else {
	    TclEmitInstInt4(	INST_OVER, 1,			envPtr);
	}
	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
	TclEmitOpcode(		INST_DUP,			envPtr);
	offset = CurrentOffset(envPtr);
	TclEmitInstInt1(	INST_JUMP_FALSE1, 0,		envPtr);

	/* List is not empty */
	TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewIntObj(idx1),
							NULL),	envPtr);
	TclEmitOpcode(		INST_GT,			envPtr);
	offset2 = CurrentOffset(envPtr);
	TclEmitInstInt1(	INST_JUMP_TRUE1, 0,		envPtr);

	/* Idx1 >= list length ===> raise an error */
	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,
		envPtr->codeStart + offset + 1);
	TclEmitOpcode(		INST_POP,			envPtr);
	TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2,
		envPtr->codeStart + offset2 + 1);
    }

    if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) {
	/*
	 * This is a "no-op". Example: [lreplace {a b c} 2 0]
	 * We still do a list operation to get list-verification
	 * and canonicalization side effects.
	 */
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);






|







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<











>
>
|







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
....
1488
1489
1490
1491
1492
1493
1494

















1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
....
1533
1534
1535
1536
1537
1538
1539




































1540
1541
1542
1543
1544
1545
1546
				 * command. */
    Command *cmdPtr,		/* Points to defintion of command being
				 * compiled. */
    CompileEnv *envPtr)		/* Holds the resulting instructions. */
{
    Tcl_Token *tokenPtr, *listTokenPtr;
    DefineLineInformation;	/* TIP #280 */
    int idx1, idx2, i;
    int emptyPrefix=1, suffixStart = 0;

    if (parsePtr->numWords < 4) {
	return TCL_ERROR;
    }
    listTokenPtr = TokenAfter(parsePtr->tokenPtr);

................................................................................

    tokenPtr = TokenAfter(tokenPtr);
    if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
	    &idx2) != TCL_OK) {
	return TCL_ERROR;
    }


















    /*
     * General structure of the [lreplace] result is
     *		prefix replacement suffix
     * In a few cases we can predict various parts will be empty and
     * take advantage.
     *
     * The proper suffix begins with the greater of indices idx1 or
     * idx2 + 1. If we cannot tell at compile time which is greater,
     * we must defer to direct evaluation.
     */

    if (idx1 == TCL_INDEX_AFTER) {
	suffixStart = idx1;
    } else if (idx2 == TCL_INDEX_BEFORE) {
	suffixStart = idx1;
    } else if (idx2 == TCL_INDEX_END) {
	suffixStart = TCL_INDEX_AFTER;
    } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END))
	    || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) {
	suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
    } else {
................................................................................

	/* Make a list of them... */
	TclEmitInstInt4(	INST_LIST, i - 4,		envPtr);

	emptyPrefix = 0;
    }
     




































    if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) {
	/*
	 * This is a "no-op". Example: [lreplace {a b c} 2 0]
	 * We still do a list operation to get list-verification
	 * and canonicalization side effects.
	 */
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);

Changes to tests/lreplace.test.

96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
...
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
    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} -body {
    lreplace x 1 1
} -returnCodes 1 -result {list doesn't contain element 1}
test lreplace-1.28 {lreplace command} -body {
    lreplace x 1 1 y
} -returnCodes 1 -result {list doesn't contain element 1}
test lreplace-1.29 {lreplace command} -body {
    lreplace x 1 1 [error foo]
} -returnCodes 1 -result {foo}
test lreplace-1.30 {lreplace command} -body {
    lreplace {not {}alist} 0 0 [error foo]
} -returnCodes 1 -result {foo}

................................................................................
    list [catch {lreplace x 10 x} msg] $msg
} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.5 {lreplace errors} {
    list [catch {lreplace x 10 1x} msg] $msg
} {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 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"
    }
    p






|


|







 







|


|







96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
...
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
    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} -body {
    lreplace x 1 1
} -result x
test lreplace-1.28 {lreplace command} -body {
    lreplace x 1 1 y
} -result {x y}
test lreplace-1.29 {lreplace command} -body {
    lreplace x 1 1 [error foo]
} -returnCodes 1 -result {foo}
test lreplace-1.30 {lreplace command} -body {
    lreplace {not {}alist} 0 0 [error foo]
} -returnCodes 1 -result {foo}

................................................................................
    list [catch {lreplace x 10 x} msg] $msg
} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.5 {lreplace errors} {
    list [catch {lreplace x 10 1x} msg] $msg
} {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
} {0 x}
test lreplace-2.7 {lreplace errors} {
    list [catch {lreplace x 2 2} msg] $msg
} {0 x}

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"
    }
    p