summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2022-10-03 08:53:58 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2022-10-03 08:53:58 (GMT)
commitfbbee7fe2ac6e38de8eb2c3d5a85435bd107cd8e (patch)
tree5266bf13582701a3d595cc4750e4bf15ed514b1d
parenteb48fd5bf76e88f1abb1d3938b8b5bad5e5edb6d (diff)
parent5d3af5f62717c5ddd028c528ff1f89d481b5e63d (diff)
downloadtcl-fbbee7fe2ac6e38de8eb2c3d5a85435bd107cd8e.zip
tcl-fbbee7fe2ac6e38de8eb2c3d5a85435bd107cd8e.tar.gz
tcl-fbbee7fe2ac6e38de8eb2c3d5a85435bd107cd8e.tar.bz2
Merge 8.7
-rw-r--r--doc/interp.n20
-rw-r--r--doc/lappend.n4
-rw-r--r--doc/lassign.n4
-rw-r--r--doc/ledit.n91
-rw-r--r--doc/lindex.n4
-rw-r--r--doc/linsert.n4
-rw-r--r--doc/list.n4
-rw-r--r--doc/llength.n4
-rw-r--r--doc/lmap.n4
-rw-r--r--doc/lpop.n4
-rw-r--r--doc/lrange.n4
-rw-r--r--doc/lremove.n4
-rw-r--r--doc/lrepeat.n4
-rw-r--r--doc/lreplace.n4
-rw-r--r--doc/lreverse.n4
-rw-r--r--doc/lsearch.n4
-rw-r--r--doc/lseq.n4
-rw-r--r--doc/lset.n4
-rw-r--r--doc/lsort.n4
-rw-r--r--generic/tcl.decls6
-rwxr-xr-xgeneric/tclArithSeries.c80
-rw-r--r--generic/tclArithSeries.h13
-rw-r--r--generic/tclBasic.c1
-rw-r--r--generic/tclCmdAH.c7
-rw-r--r--generic/tclCmdIL.c150
-rw-r--r--generic/tclDecls.h25
-rw-r--r--generic/tclExecute.c8
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclListObj.c5
-rw-r--r--generic/tclTest.c9
-rw-r--r--tests/lreplace.test295
-rw-r--r--tests/lseq.test43
32 files changed, 718 insertions, 106 deletions
diff --git a/doc/interp.n b/doc/interp.n
index 2943404..08bed1c 100644
--- a/doc/interp.n
+++ b/doc/interp.n
@@ -591,16 +591,16 @@ built-in commands:
\fBflush\fR \fBfor\fR \fBforeach\fR \fBformat\fR
\fBgets\fR \fBglobal\fR \fBif\fR \fBincr\fR
\fBinfo\fR \fBinterp\fR \fBjoin\fR \fBlappend\fR
-\fBlassign\fR \fBlindex\fR \fBlinsert\fR \fBlist\fR
-\fBllength\fR \fBlrange\fR \fBlrepeat\fR \fBlreplace\fR
-\fBlsearch\fR \fBlset\fR \fBlsort\fR \fBnamespace\fR
-\fBpackage\fR \fBpid\fR \fBproc\fR \fBputs\fR
-\fBread\fR \fBregexp\fR \fBregsub\fR \fBrename\fR
-\fBreturn\fR \fBscan\fR \fBseek\fR \fBset\fR
-\fBsplit\fR \fBstring\fR \fBsubst\fR \fBswitch\fR
-\fBtell\fR \fBtime\fR \fBtrace\fR \fBunset\fR
-\fBupdate\fR \fBuplevel\fR \fBupvar\fR \fBvariable\fR
-\fBvwait\fR \fBwhile\fR
+\fBlassign\fR \fBledit\fR \fBlindex\fR \fBlinsert\fR
+\fBlist\fR \fBllength\fR \fBlrange\fR \fBlrepeat\fR
+\fBlreplace\fR \fBlsearch\fR \fBlseq\fR \fBlset\fR
+\fBlsort\fR \fBnamespace\fR \fBpackage\fR \fBpid\fR
+\fBproc\fR \fBputs\fR \fBread\fR \fBregexp\fR
+\fBregsub\fR \fBrename\fR \fBreturn\fR \fBscan\fR
+\fBseek\fR \fBset\fR \fBsplit\fR \fBstring\fR
+\fBsubst\fR \fBswitch\fR \fBtell\fR \fBtime\fR
+\fBtrace\fR \fBunset\fR \fBupdate\fR \fBuplevel\fR
+\fBupvar\fR \fBvariable\fR \fBvwait\fR \fBwhile\fR
.DE
The following commands are hidden by \fBinterp create\fR when it
creates a safe interpreter:
diff --git a/doc/lappend.n b/doc/lappend.n
index 89b6909..3fbda79 100644
--- a/doc/lappend.n
+++ b/doc/lappend.n
@@ -49,9 +49,9 @@ Using \fBlappend\fR to build up a list of numbers.
1 2 3 4 5
.CE
.SH "SEE ALSO"
-list(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n)
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
append, element, list, variable
.\" Local variables:
diff --git a/doc/lassign.n b/doc/lassign.n
index 67048ba..d23509a 100644
--- a/doc/lassign.n
+++ b/doc/lassign.n
@@ -52,9 +52,9 @@ command in many shell languages like this:
set ::argv [\fBlassign\fR $::argv argumentToReadOff]
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n)
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
assign, element, list, multiple, set, variable
'\"Local Variables:
diff --git a/doc/ledit.n b/doc/ledit.n
new file mode 100644
index 0000000..70e0bf3
--- /dev/null
+++ b/doc/ledit.n
@@ -0,0 +1,91 @@
+'\"
+'\" Copyright (c) 2022 Ashok P. Nadkarni <apnmbx-public@yahoo.com>. All rights reserved.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH ledit n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+ledit \- Replace elements of a list stored in variable
+.SH SYNOPSIS
+\fBledit \fIlistVar first last \fR?\fIvalue value ...\fR?
+.BE
+.SH DESCRIPTION
+.PP
+The command fetches the list value in variable \fIlistVar\fR and replaces the
+elements in the range given by indices \fIfirst\fR to \fIlast\fR (inclusive)
+with the \fIvalue\fR arguments. The resulting list is then stored back in
+\fIlistVar\fR and returned as the result of the command.
+.PP
+Arguments \fIfirst\fR and \fIlast\fR are index values specifying the first and
+last elements of the range to replace. They are interpreted
+the same as index values for the command \fBstring index\fR,
+supporting simple index arithmetic and indices relative to the
+end of the list. The index 0 refers to the first element of the
+list, and \fBend\fR refers to the last element of the list.
+.PP
+If either \fIfirst\fR or \fIlast\fR is less than zero, it is considered to
+refer to the position before the first element of the list. This allows
+elements to be prepended.
+.PP
+If either \fIfirst\fR or \fIlast\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 elements to be appended.
+.PP
+If \fIlast\fR is less than \fIfirst\fR, then any specified elements
+will be inserted into the list before the element specified by \fIfirst\fR
+with no elements being deleted.
+.PP
+The \fIvalue\fR arguments specify zero or more new elements to
+be added to the list in place of those that were deleted.
+Each \fIvalue\fR argument will become a separate element of
+the list. If no \fIvalue\fR arguments are specified, then the elements
+between \fIfirst\fR and \fIlast\fR are simply deleted.
+.SH EXAMPLES
+.PP
+Prepend to a list.
+.PP
+.CS
+% set lst {c d e f g}
+c d e f g
+% ledit lst -1 -1 a b
+a b c d e f g
+.CE
+.PP
+Append to the list.
+.PP
+.CS
+% ledit lst end+1 end+1 h i
+a b c d e f g h i
+.CE
+.PP
+Delete third and fourth elements.
+.PP
+.CS
+% ledit lst 2 3
+a b e f g h i
+.CE
+.PP
+Replace two elements with three.
+.PP
+.CS
+% ledit lst 2 3 x y z
+a b x y z g h i
+% set lst
+a b x y z g h i
+.CE
+.PP
+.SH "SEE ALSO"
+list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
+string(n)
+.SH KEYWORDS
+element, list, replace
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/lindex.n b/doc/lindex.n
index 75fe5e8..d4d845d 100644
--- a/doc/lindex.n
+++ b/doc/lindex.n
@@ -115,9 +115,9 @@ set idx 3
\fI\(-> f\fR
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, index, list
diff --git a/doc/linsert.n b/doc/linsert.n
index 3179256..014f9cd 100644
--- a/doc/linsert.n
+++ b/doc/linsert.n
@@ -45,9 +45,9 @@ set newList [\fBlinsert\fR $midList end-1 lazy]
set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy]
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), lindex(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, insert, list
diff --git a/doc/list.n b/doc/list.n
index 3fa1975..08a6fe7 100644
--- a/doc/list.n
+++ b/doc/list.n
@@ -46,9 +46,9 @@ while \fBconcat\fR with the same arguments will return
\fBa b c d e f {g h}\fR
.CE
.SH "SEE ALSO"
-lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n)
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, quoting
'\"Local Variables:
diff --git a/doc/llength.n b/doc/llength.n
index 26824a0..574834f 100644
--- a/doc/llength.n
+++ b/doc/llength.n
@@ -49,9 +49,9 @@ An empty list is not necessarily an empty string:
1,0
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), lindex(n), linsert(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n)
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, length
'\" Local Variables:
diff --git a/doc/lmap.n b/doc/lmap.n
index 026e9d0..36a0c7c 100644
--- a/doc/lmap.n
+++ b/doc/lmap.n
@@ -78,9 +78,9 @@ set prefix [\fBlmap\fR x $values {expr {
.CE
.SH "SEE ALSO"
break(n), continue(n), for(n), foreach(n), while(n),
-list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n)
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
foreach, iteration, list, loop, map
'\" Local Variables:
diff --git a/doc/lpop.n b/doc/lpop.n
index 3d88638..2a464eb 100644
--- a/doc/lpop.n
+++ b/doc/lpop.n
@@ -86,9 +86,9 @@ The indicated value becomes the new value of \fIx\fR.
\fI\(-> {{a b} {c d}} {{e f} h}\fR
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, index, list, remove, pop, stack, queue
diff --git a/doc/lrange.n b/doc/lrange.n
index 0d4b261..38c4abf 100644
--- a/doc/lrange.n
+++ b/doc/lrange.n
@@ -71,9 +71,9 @@ elements to
{elements to}
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, range, sublist
diff --git a/doc/lremove.n b/doc/lremove.n
index 59d261b..8763ea6 100644
--- a/doc/lremove.n
+++ b/doc/lremove.n
@@ -46,9 +46,9 @@ Removing the same element indicated in two different ways:
a b d e
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n)
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, remove
.\" Local variables:
diff --git a/doc/lrepeat.n b/doc/lrepeat.n
index 9a3fc88..cd672db 100644
--- a/doc/lrepeat.n
+++ b/doc/lrepeat.n
@@ -32,9 +32,9 @@ is identical to \fBlist element ...\fR.
\fI\(-> {a a} b c {a a} b c {a a} b c\fR
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n), lsort(n)
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
element, index, list
'\" Local Variables:
diff --git a/doc/lreplace.n b/doc/lreplace.n
index bc9d7ca..47d33f9 100644
--- a/doc/lreplace.n
+++ b/doc/lreplace.n
@@ -95,9 +95,9 @@ a b c d e f g h i
.CE
.VE TIP505
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n),
-lreverse(n), lsearch(n), lset(n), lsort(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, replace
diff --git a/doc/lreverse.n b/doc/lreverse.n
index e2e3b69..bb0703d 100644
--- a/doc/lreverse.n
+++ b/doc/lreverse.n
@@ -25,9 +25,9 @@ input list, \fIlist\fR, except with the elements in the reverse order.
\fI\(-> f e {c d} b a\fR
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lsearch(n), lset(n), lsort(n)
+lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, reverse
'\" Local Variables:
diff --git a/doc/lsearch.n b/doc/lsearch.n
index c5dc98f..dc6d1f7 100644
--- a/doc/lsearch.n
+++ b/doc/lsearch.n
@@ -229,9 +229,9 @@ The same thing for a flattened list:
.CE
.SH "SEE ALSO"
foreach(n),
-list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lset(n), lsort(n),
+lreverse(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
binary search, linear search,
diff --git a/doc/lseq.n b/doc/lseq.n
index 5c7d03b..df8a8bc 100644
--- a/doc/lseq.n
+++ b/doc/lseq.n
@@ -81,8 +81,8 @@ must be numeric; a non-numeric string will result in an error.
.\"
.CE
.SH "SEE ALSO"
-foreach(n), list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
-lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n),
+foreach(n), list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n),
+llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
element, index, list
diff --git a/doc/lset.n b/doc/lset.n
index 4b97ed6..e2e1590 100644
--- a/doc/lset.n
+++ b/doc/lset.n
@@ -136,9 +136,9 @@ The indicated return value also becomes the new value of \fIx\fR.
\fI\(-> {{a b} {c d}} {{e f} {j h}}\fR
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lsort(n)
+lreverse(n), lsearch(n), lseq(n), lsort(n)
string(n)
.SH KEYWORDS
element, index, list, replace, set
diff --git a/doc/lsort.n b/doc/lsort.n
index 2018e30..1695ea8 100644
--- a/doc/lsort.n
+++ b/doc/lsort.n
@@ -264,9 +264,9 @@ More complex sorting using a comparison function:
{1 dingo} {2 banana} {0x2 carrot} {3 apple}
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
-lreverse(n), lsearch(n), lset(n)
+lreverse(n), lsearch(n), lseq(n), lset(n)
.SH KEYWORDS
element, list, order, sort
'\" Local Variables:
diff --git a/generic/tcl.decls b/generic/tcl.decls
index ce80f68..95cecdf 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -1043,7 +1043,7 @@ declare 288 {
declare 289 {
void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
-declare 290 {
+declare 290 {deprecated {Use Tcl_DiscardInterpState}} {
void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
declare 291 {
@@ -1126,10 +1126,10 @@ declare 313 {
int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
int charsToRead, int appendFlag)
}
-declare 314 {
+declare 314 {deprecated {Use Tcl_RestoreInterpState}} {
void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
-declare 315 {
+declare 315 {deprecated {Use Tcl_SaveInterpState}} {
void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 316 {
diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c
index 93177a7..ee201fa 100755
--- a/generic/tclArithSeries.c
+++ b/generic/tclArithSeries.c
@@ -106,8 +106,10 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step)
{
Tcl_WideInt len;
- if (step == 0) return 0;
- len = (step ? (1 + (((end-start))/step)) : 0);
+ if (step == 0) {
+ return 0;
+ }
+ len = 1 + ((end-start)/step);
return (len < 0) ? -1 : len;
}
@@ -227,26 +229,24 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len)
static void
assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj)
{
- union {
- double d;
- Tcl_WideInt i;
- } *number;
+ void *clientData;
int tcl_number_type;
- if (TclGetNumberFromObj(NULL, numberObj, (ClientData*)&number, &tcl_number_type) != TCL_OK) {
+ if (TclGetNumberFromObj(NULL, numberObj, &clientData, &tcl_number_type) != TCL_OK
+ || tcl_number_type == TCL_NUMBER_BIG) {
return;
}
if (useDoubles) {
- if (tcl_number_type == TCL_NUMBER_DOUBLE) {
- *dblNumberPtr = number->d;
+ if (tcl_number_type != TCL_NUMBER_INT) {
+ *dblNumberPtr = *(double *)clientData;
} else {
- *dblNumberPtr = (double)number->i;
+ *dblNumberPtr = (double)*(Tcl_WideInt *)clientData;
}
} else {
if (tcl_number_type == TCL_NUMBER_INT) {
- *intNumberPtr = number->i;
+ *intNumberPtr = *(Tcl_WideInt *)clientData;
} else {
- *intNumberPtr = (Tcl_WideInt)number->d;
+ *intNumberPtr = (Tcl_WideInt)*(double *)clientData;
}
}
}
@@ -270,8 +270,16 @@ assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tc
* None.
*----------------------------------------------------------------------
*/
-Tcl_Obj *
-TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj)
+int
+TclNewArithSeriesObj(
+ Tcl_Interp *interp, /* For error reporting */
+ Tcl_Obj **arithSeriesObj, /* return value */
+ int useDoubles, /* Flag indicates values start,
+ ** end, step, are treated as doubles */
+ Tcl_Obj *startObj, /* Starting value */
+ Tcl_Obj *endObj, /* Ending limit */
+ Tcl_Obj *stepObj, /* increment value */
+ Tcl_Obj *lenObj) /* Number of elements */
{
double dstart, dend, dstep;
Tcl_WideInt start, end, step, len;
@@ -290,7 +298,8 @@ TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj
dstep = step;
}
if (dstep == 0) {
- return Tcl_NewObj();
+ *arithSeriesObj = Tcl_NewObj();
+ return TCL_OK;
}
}
if (endObj) {
@@ -330,11 +339,20 @@ TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj
}
}
- if (useDoubles) {
- return TclNewArithSeriesDbl(dstart, dend, dstep, len);
- } else {
- return TclNewArithSeriesInt(start, end, step, len);
+ if (len > ListSizeT_MAX) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ return TCL_ERROR;
+ }
+
+ if (arithSeriesObj) {
+ *arithSeriesObj = (useDoubles)
+ ? TclNewArithSeriesDbl(dstart, dend, dstep, len)
+ : TclNewArithSeriesInt(start, end, step, len);
}
+ return TCL_OK;
}
/*
@@ -374,6 +392,7 @@ TclArithSeriesObjStep(
} else {
*stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step);
}
+ Tcl_IncrRefCount(*stepObj);
return TCL_OK;
}
@@ -418,6 +437,7 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele
} else {
*elementObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index));
}
+ Tcl_IncrRefCount(*elementObj);
return TCL_OK;
}
@@ -684,6 +704,7 @@ TclArithSeriesObjCopy(
Tcl_Obj *
TclArithSeriesObjRange(
+ Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesPtr, /* List object to take a range from. */
int fromIdx, /* Index of first element to include. */
int toIdx) /* Index of last element to include. */
@@ -703,16 +724,17 @@ TclArithSeriesObjRange(
}
TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj);
- Tcl_IncrRefCount(startObj);
TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj);
- Tcl_IncrRefCount(endObj);
TclArithSeriesObjStep(arithSeriesPtr, &stepObj);
- Tcl_IncrRefCount(stepObj);
if (Tcl_IsShared(arithSeriesPtr) ||
((arithSeriesPtr->refCount > 1))) {
- Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(arithSeriesRepPtr->isDouble,
- startObj, endObj, stepObj, NULL);
+ Tcl_Obj *newSlicePtr;
+ if (TclNewArithSeriesObj(interp, &newSlicePtr,
+ arithSeriesRepPtr->isDouble, startObj, endObj,
+ stepObj, NULL) != TCL_OK) {
+ newSlicePtr = NULL;
+ }
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
@@ -795,7 +817,7 @@ TclArithSeriesGetElements(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *objPtr, /* AbstractList object for which an element
* array is to be returned. */
- int *objcPtr, /* Where to store the count of objects
+ ListSizeT *objcPtr, /* Where to store the count of objects
* referenced by objv. */
Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
* pointers to the list's objects. */
@@ -834,7 +856,6 @@ TclArithSeriesGetElements(
}
return TCL_ERROR;
}
- Tcl_IncrRefCount(objv[i]);
}
}
} else {
@@ -875,6 +896,7 @@ TclArithSeriesGetElements(
Tcl_Obj *
TclArithSeriesObjReverse(
+ Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesPtr) /* List object to reverse. */
{
ArithSeries *arithSeriesRepPtr;
@@ -910,8 +932,10 @@ TclArithSeriesObjReverse(
if (Tcl_IsShared(arithSeriesPtr) ||
((arithSeriesPtr->refCount > 1))) {
Tcl_Obj *lenObj = Tcl_NewWideIntObj(len);
- resultObj = TclNewArithSeriesObj(isDouble,
- startObj, endObj, stepObj, lenObj);
+ if (TclNewArithSeriesObj(interp, &resultObj,
+ isDouble, startObj, endObj, stepObj, lenObj) != TCL_OK) {
+ resultObj = NULL;
+ }
Tcl_DecrRefCount(lenObj);
} else {
diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h
index f855c22..3ace052 100644
--- a/generic/tclArithSeries.h
+++ b/generic/tclArithSeries.h
@@ -40,9 +40,10 @@ MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr,
MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr,
Tcl_WideInt index, Tcl_Obj **elementObj);
MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr);
-MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr,
- int fromIdx, int toIdx);
-MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesPtr, int fromIdx, int toIdx);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesPtr);
MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp,
Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr);
MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start,
@@ -50,5 +51,7 @@ MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start,
Tcl_WideInt len);
MODULE_SCOPE Tcl_Obj * TclNewArithSeriesDbl(double start, double end,
double step, Tcl_WideInt len);
-MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj,
- Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj);
+MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp,
+ Tcl_Obj **arithSeriesObj, int useDoubles,
+ Tcl_Obj *startObj, Tcl_Obj *endObj,
+ Tcl_Obj *stepObj, Tcl_Obj *lenObj);
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 83111b1..73b997d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -325,6 +325,7 @@ static const CmdInfo builtInCmds[] = {
{"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE},
{"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
{"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE},
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE},
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 07541bd..3048e82 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -3027,6 +3027,13 @@ ForeachAssignments(
varValuePtr = Tcl_ObjSetVar2(interp, statePtr->varvList[i][v],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
+ if (isarithseries) {
+ /* arith values have implicit reference
+ ** Make sure value is cleaned up when var goes away
+ */
+ Tcl_DecrRefCount(valuePtr);
+ }
+
if (varValuePtr == NULL) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (setting %s loop variable \"%s\")",
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 9430eb5..62ceeea 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2720,7 +2720,6 @@ Tcl_LrangeObjCmd(
/* Argument objects. */
{
int listLen, first, last, result;
-
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
@@ -2744,7 +2743,13 @@ Tcl_LrangeObjCmd(
}
if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
- Tcl_SetObjResult(interp, TclArithSeriesObjRange(objv[1], first, last));
+ Tcl_Obj *rangeObj;
+ rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last);
+ if (rangeObj) {
+ Tcl_SetObjResult(interp, rangeObj);
+ } else {
+ return TCL_ERROR;
+ }
} else {
Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
}
@@ -3137,8 +3142,13 @@ Tcl_LreverseObjCmd(
* just to reverse it.
*/
if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
- Tcl_SetObjResult(interp, TclArithSeriesObjReverse(objv[1]));
- return TCL_OK;
+ Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]);
+ if (resObj) {
+ Tcl_SetObjResult(interp, resObj);
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
} /* end ArithSeries */
/* True List */
@@ -4067,12 +4077,9 @@ SequenceIdentifyArgument(
int status;
SequenceOperators opmode;
SequenceByMode bymode;
- union {
- Tcl_WideInt i;
- double d;
- } nvalue;
+ void *clientData;
- status = TclGetNumberFromObj(NULL, argPtr, (ClientData*)&nvalue, keywordIndexPtr);
+ status = TclGetNumberFromObj(NULL, argPtr, &clientData, keywordIndexPtr);
if (status == TCL_OK) {
if (numValuePtr) {
*numValuePtr = argPtr;
@@ -4422,10 +4429,12 @@ Tcl_LseqObjCmd(
/*
* Success! Now lets create the series object.
*/
- arithSeriesPtr = TclNewArithSeriesObj(useDoubles, start, end, step, elementCount);
+ status = TclNewArithSeriesObj(interp, &arithSeriesPtr,
+ useDoubles, start, end, step, elementCount);
- Tcl_SetObjResult(interp, arithSeriesPtr);
- status = TCL_OK;
+ if (status == TCL_OK) {
+ Tcl_SetObjResult(interp, arithSeriesPtr);
+ }
done:
// Free number arguments.
@@ -4961,6 +4970,123 @@ Tcl_LsortObjCmd(
/*
*----------------------------------------------------------------------
*
+ * Tcl_LeditObjCmd --
+ *
+ * This procedure is invoked to process the "ledit" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LeditObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument values. */
+{
+ Tcl_Obj *listPtr; /* Pointer to the list being altered. */
+ Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
+ int createdNewObj;
+ int result;
+ int first;
+ int last;
+ int listLen;
+ int numToDelete;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "listVar first last ?element ...?");
+ return TCL_ERROR;
+ }
+
+ listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * TODO - refactor the index extraction into a common function shared
+ * by Tcl_{Lrange,Lreplace,Ledit}ObjCmd
+ */
+
+ result = TclListObjLengthM(interp, listPtr, &listLen);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ if (first == TCL_INDEX_NONE) {
+ first = 0;
+ } else if (first > listLen) {
+ first = listLen;
+ }
+
+ if (last >= listLen) {
+ last = listLen - 1;
+ }
+ if (first <= last) {
+ numToDelete = last - first + 1;
+ } else {
+ numToDelete = 0;
+ }
+
+ if (Tcl_IsShared(listPtr)) {
+ listPtr = TclListObjCopy(NULL, listPtr);
+ createdNewObj = 1;
+ } else {
+ createdNewObj = 0;
+ }
+
+ result =
+ Tcl_ListObjReplace(interp, listPtr, first, numToDelete, objc - 4, objv + 4);
+ if (result != TCL_OK) {
+ if (createdNewObj) {
+ Tcl_DecrRefCount(listPtr);
+ }
+ return result;
+ }
+
+ /*
+ * Tcl_ObjSetVar2 mau return a value different from listPtr in the
+ * presence of traces etc.. Note that finalValuePtr will always have a
+ * reference count of at least 1 corresponding to the reference from the
+ * var. If it is same as listPtr, then ref count will be at least 2
+ * since we are incr'ing the latter below (safer when calling
+ * Tcl_ObjSetVar2 which can release it in some cases). Note that we
+ * leave the incrref of listPtr this late because we want to pass it as
+ * unshared to Tcl_ListObjReplace above if possible.
+ */
+ Tcl_IncrRefCount(listPtr);
+ finalValuePtr =
+ Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(listPtr); /* safe irrespective of createdNewObj */
+ if (finalValuePtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, finalValuePtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* MergeLists -
*
* This procedure combines two sorted lists of SortElement structures
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index ac25d29..2d18bcc 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -900,7 +900,8 @@ EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc,
EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc,
void *clientData);
/* 290 */
-EXTERN void Tcl_DiscardResult(Tcl_SavedResult *statePtr);
+TCL_DEPRECATED("Use Tcl_DiscardInterpState")
+void Tcl_DiscardResult(Tcl_SavedResult *statePtr);
/* 291 */
EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script,
int numBytes, int flags);
@@ -965,10 +966,12 @@ EXTERN int Tcl_NumUtfChars(const char *src, int length);
EXTERN int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
int charsToRead, int appendFlag);
/* 314 */
-EXTERN void Tcl_RestoreResult(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_RestoreInterpState")
+void Tcl_RestoreResult(Tcl_Interp *interp,
Tcl_SavedResult *statePtr);
/* 315 */
-EXTERN void Tcl_SaveResult(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_SaveInterpState")
+void Tcl_SaveResult(Tcl_Interp *interp,
Tcl_SavedResult *statePtr);
/* 316 */
EXTERN int Tcl_SetSystemEncoding(Tcl_Interp *interp,
@@ -2331,7 +2334,7 @@ typedef struct TclStubs {
Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */
void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */
void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */
- void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */
+ TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */
int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */
int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */
int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */
@@ -2355,8 +2358,8 @@ typedef struct TclStubs {
void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */
int (*tcl_NumUtfChars) (const char *src, int length); /* 312 */
int (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); /* 313 */
- void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */
- void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */
+ TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */
+ TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */
int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */
Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */
@@ -4234,22 +4237,30 @@ extern const TclStubs *tclStubsPtr;
#define Tcl_GlobalEval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL)
#undef Tcl_SaveResult
+static TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void Tcl_SaveResult_(void) {}
#define Tcl_SaveResult(interp, statePtr) \
do { \
+ Tcl_SaveResult_(); \
(statePtr)->objResultPtr = Tcl_GetObjResult(interp); \
Tcl_IncrRefCount((statePtr)->objResultPtr); \
Tcl_SetObjResult(interp, Tcl_NewObj()); \
} while(0)
#undef Tcl_RestoreResult
+static TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void Tcl_RestoreResult_(void) {}
#define Tcl_RestoreResult(interp, statePtr) \
do { \
+ Tcl_RestoreResult_(); \
Tcl_ResetResult(interp); \
Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \
Tcl_DecrRefCount((statePtr)->objResultPtr); \
} while(0)
#undef Tcl_DiscardResult
+static TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_(void) {}
#define Tcl_DiscardResult(statePtr) \
- Tcl_DecrRefCount((statePtr)->objResultPtr)
+ do { \
+ Tcl_DiscardResult_(); \
+ Tcl_DecrRefCount((statePtr)->objResultPtr); \
+ } while(0)
#undef Tcl_SetResult
#define Tcl_SetResult(interp, result, freeProc) \
do { \
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f8d5493..fa0dfa2 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4938,7 +4938,7 @@ TEBCresume(
/* Decode end-offset index values. */
- index = TclIndexDecode(opnd, length);
+ index = TclIndexDecode(opnd, length-1);
/* Compute value @ index */
if (index >= 0 && index < length) {
@@ -5154,7 +5154,11 @@ TEBCresume(
fromIdx = TclIndexDecode(fromIdx, objc - 1);
if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) {
- objResultPtr = TclArithSeriesObjRange(valuePtr, fromIdx, toIdx);
+ objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx);
+ if (objResultPtr == NULL) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
} else {
objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx);
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index db0b4f7..bc605db 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3689,6 +3689,9 @@ MODULE_SCOPE int Tcl_LappendObjCmd(void *clientData,
MODULE_SCOPE int Tcl_LassignObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LeditObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_LindexObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 5034174..598ff6f 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -2632,7 +2632,8 @@ TclLindexFlat(
/* Handle ArithSeries as special case */
if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
- ListSizeT index, listLen = TclArithSeriesObjLength(listObj);
+ Tcl_WideInt listLen = TclArithSeriesObjLength(listObj);
+ ListSizeT index;
Tcl_Obj *elemObj = NULL;
for (i=0 ; i<indexCount && listObj ; i++) {
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
@@ -2640,7 +2641,6 @@ TclLindexFlat(
}
if (i==0) {
TclArithSeriesObjIndex(listObj, index, &elemObj);
- Tcl_IncrRefCount(elemObj);
} else if (index > 0) {
Tcl_DecrRefCount(elemObj);
TclNewObj(elemObj);
@@ -3303,7 +3303,6 @@ SetListFromAny(
if (TclArithSeriesObjIndex(objPtr, j, &elemPtrs[j]) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_IncrRefCount(elemPtrs[j]);/* Since list now holds ref to it. */
}
} else {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index a40b6b1..8218a33 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -176,6 +176,15 @@ typedef struct TestChannel {
static TestChannel *firstDetached;
+#ifdef __GNUC__
+/*
+ * The rest of this file shouldn't warn about deprecated functions; they're
+ * there because we intend them to be so and know that this file is OK to
+ * touch those fields.
+ */
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
+
/*
* Forward declarations for procedures defined later in this file:
*/
diff --git a/tests/lreplace.test b/tests/lreplace.test
index 0b26e86..2952899 100644
--- a/tests/lreplace.test
+++ b/tests/lreplace.test
@@ -236,6 +236,301 @@ apply {{} {
}
}}
+# Essentially same tests as above but for ledit
+test ledit-1.1 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 0 0 a] $l
+} {{a 2 3 4 5} {a 2 3 4 5}}
+test ledit-1.2 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 1 1 a] $l
+} {{1 a 3 4 5} {1 a 3 4 5}}
+test ledit-1.3 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 2 2 a] $l
+} {{1 2 a 4 5} {1 2 a 4 5}}
+test ledit-1.4 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 3 3 a] $l
+} {{1 2 3 a 5} {1 2 3 a 5}}
+test ledit-1.5 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 4 4 a] $l
+} {{1 2 3 4 a} {1 2 3 4 a}}
+test ledit-1.6 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 4 5 a] $l
+} {{1 2 3 4 a} {1 2 3 4 a}}
+test ledit-1.7 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l -1 -1 a] $l
+} {{a 1 2 3 4 5} {a 1 2 3 4 5}}
+test ledit-1.8 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 2 end a b c d] $l
+} {{1 2 a b c d} {1 2 a b c d}}
+test ledit-1.9 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 0 3] $l
+} {5 5}
+test ledit-1.10 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 0 4] $l
+} {{} {}}
+test ledit-1.11 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 0 1] $l
+} {{3 4 5} {3 4 5}}
+test ledit-1.12 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 2 3] $l
+} {{1 2 5} {1 2 5}}
+test ledit-1.13 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 3 end] $l
+} {{1 2 3} {1 2 3}}
+test ledit-1.14 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l -1 4 a b c] $l
+} {{a b c} {a b c}}
+test ledit-1.15 {ledit command} {
+ set l {a b "c c" d e f}
+ list [ledit l 3 3] $l
+} {{a b {c c} e f} {a b {c c} e f}}
+test ledit-1.16 {ledit command} {
+ set l { 1 2 3 4 5}
+ list [ledit l 0 0 a] $l
+} {{a 2 3 4 5} {a 2 3 4 5}}
+test ledit-1.17 {ledit command} {
+ set l {1 2 3 4 "5 6"}
+ list [ledit l 4 4 a] $l
+} {{1 2 3 4 a} {1 2 3 4 a}}
+test ledit-1.18 {ledit command} {
+ set l {1 2 3 4 {5 6}}
+ list [ledit l 4 4 a] $l
+} {{1 2 3 4 a} {1 2 3 4 a}}
+test ledit-1.19 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l 2 end x y z] $l
+} {{1 2 x y z} {1 2 x y z}}
+test ledit-1.20 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l end end a] $l
+} {{1 2 3 a} {1 2 3 a}}
+test ledit-1.21 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l end 3 a] $l
+} {{1 2 3 a} {1 2 3 a}}
+test ledit-1.22 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l end end] $l
+} {{1 2 3} {1 2 3}}
+test ledit-1.23 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l 2 -1 xy] $l
+} {{1 2 xy 3 4} {1 2 xy 3 4}}
+test ledit-1.24 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l end -1 z] $l
+} {{1 2 3 z 4} {1 2 3 z 4}}
+test ledit-1.25 {ledit command} {
+ set l {\}\ hello}
+ concat \"[ledit l end end]\" $l
+} {"\}\ " \}\ }
+test ledit-1.26 {ledit command} {
+ catch {unset foo}
+ set foo {a b}
+ list [ledit foo end end] $foo \
+ [ledit foo end end] $foo \
+ [ledit foo end end] $foo
+} {a a {} {} {} {}}
+test ledit-1.27 {lsubset command} -body {
+ set l x
+ list [ledit l 1 1] $l
+} -result {x x}
+test ledit-1.28 {ledit command} -body {
+ set l x
+ list [ledit l 1 1 y] $l
+} -result {{x y} {x y}}
+test ledit-1.29 {ledit command} -body {
+ set l x
+ ledit l 1 1 [error foo]
+} -returnCodes 1 -result {foo}
+test ledit-1.30 {ledit command} -body {
+ set l {not {}alist}
+ ledit l 0 0 [error foo]
+} -returnCodes 1 -result {foo}
+test ledit-1.31 {ledit command} -body {
+ unset -nocomplain arr
+ set arr(x) {a b}
+ list [ledit arr(x) 0 0 c] $arr(x)
+} -result {{c b} {c b}}
+
+test ledit-2.1 {ledit errors} -body {
+ list [catch ledit msg] $msg
+} -result {1 {wrong # args: should be "ledit listVar first last ?element ...?"}}
+test ledit-2.2 {ledit errors} -body {
+ unset -nocomplain x
+ list [catch {ledit l b} msg] $msg
+} -result {1 {wrong # args: should be "ledit listVar first last ?element ...?"}}
+test ledit-2.3 {ledit errors} -body {
+ set x {}
+ list [catch {ledit x a 10} msg] $msg
+} -result {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}}
+test ledit-2.4 {ledit errors} -body {
+ set l {}
+ list [catch {ledit l 10 x} msg] $msg
+} -result {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
+test ledit-2.5 {ledit errors} -body {
+ set l {}
+ list [catch {ledit l 10 1x} msg] $msg
+} -result {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
+test ledit-2.6 {ledit errors} -body {
+ set l x
+ list [catch {ledit l 3 2} msg] $msg
+} -result {0 x}
+test ledit-2.7 {ledit errors} -body {
+ set l x
+ list [catch {ledit l 2 2} msg] $msg
+} -result {0 x}
+test ledit-2.8 {ledit errors} -body {
+ unset -nocomplain l
+ ledit l 0 0 x
+} -returnCodes error -result {can't read "l": no such variable}
+test ledit-2.9 {ledit errors} -body {
+ unset -nocomplain arr
+ ledit arr(x) 0 0 x
+} -returnCodes error -result {can't read "arr(x)": no such variable}
+test ledit-2.10 {ledit errors} -body {
+ unset -nocomplain arr
+ set arr(y) y
+ ledit arr(x) 0 0 x
+} -returnCodes error -result {can't read "arr(x)": no such element in array}
+
+test ledit-3.1 {ledit won't modify shared argument objects} {
+ proc p {} {
+ set l "a b c"
+ ledit l 1 1 "x y"
+ # The literal in locals table should be unmodified
+ return [list "a b c" $l]
+ }
+ p
+} {{a b c} {a {x y} c}}
+
+# Following bugs were in lreplace. Make sure ledit does not have them
+test ledit-4.1 {Bug ccc2c2cc98: lreplace edge case} {
+ set l {}
+ list [ledit l 1 1] $l
+} {{} {}}
+test ledit-4.2 {Bug ccc2c2cc98: lreplace edge case} {
+ set l { }
+ list [ledit l 1 1] $l
+} {{} {}}
+test ledit-4.3 {lreplace edge case} {
+ set l {1 2 3}
+ ledit l 2 0
+} {1 2 3}
+test ledit-4.4 {ledit edge case} {
+ set l {1 2 3 4 5}
+ list [ledit l 3 1] $l
+} {{1 2 3 4 5} {1 2 3 4 5}}
+test lreplace-4.5 {lreplace edge case} {
+ lreplace {1 2 3 4 5} 3 0 _
+} {1 2 3 _ 4 5}
+test ledit-4.6 {ledit end-x: bug a4cb3f06c4} {
+ set l {0 1 2 3 4}
+ list [ledit l 0 end-2] $l
+} {{3 4} {3 4}}
+test ledit-4.6.1 {ledit end-x: bug a4cb3f06c4} {
+ set l {0 1 2 3 4}
+ list [ledit l 0 end-2 a b c] $l
+} {{a b c 3 4} {a b c 3 4}}
+test ledit-4.7 {ledit with two end-indexes: increasing} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-1] $l
+} {{0 1 4} {0 1 4}}
+test ledit-4.7.1 {ledit with two end-indexes: increasing} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-1 a b c] $l
+} {{0 1 a b c 4} {0 1 a b c 4}}
+test ledit-4.8 {ledit with two end-indexes: equal} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-2] $l
+} {{0 1 3 4} {0 1 3 4}}
+test ledit-4.8.1 {ledit with two end-indexes: equal} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-2 a b c] $l
+} {{0 1 a b c 3 4} {0 1 a b c 3 4}}
+test ledit-4.9 {ledit with two end-indexes: decreasing} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-3] $l
+} {{0 1 2 3 4} {0 1 2 3 4}}
+test ledit-4.9.1 {ledit with two end-indexes: decreasing} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-3 a b c] $l
+} {{0 1 a b c 2 3 4} {0 1 a b c 2 3 4}}
+test ledit-4.10 {ledit with two equal indexes} {
+ set l {0 1 2 3 4}
+ list [ledit l 2 2] $l
+} {{0 1 3 4} {0 1 3 4}}
+test ledit-4.10.1 {ledit with two equal indexes} {
+ set l {0 1 2 3 4}
+ list [ledit l 2 2 a b c] $l
+} {{0 1 a b c 3 4} {0 1 a b c 3 4}}
+test ledit-4.11 {ledit end index first} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 1 a b c] $l
+} {{0 1 a b c 2 3 4} {0 1 a b c 2 3 4}}
+test ledit-4.12 {ledit end index first} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 2 a b c] $l
+} {{0 1 a b c 3 4} {0 1 a b c 3 4}}
+test ledit-4.13 {ledit empty list} {
+ set l {}
+ list [ledit l 1 1 1] $l
+} {1 1}
+test ledit-4.14 {ledit empty list} {
+ set l {}
+ list [ledit l 2 2 2] $l
+} {2 2}
+
+test ledit-5.1 {compiled lreplace: Bug 47ac84309b} {
+ apply {x {
+ ledit x end 0
+ }} {a b c}
+} {a b c}
+test ledit-5.2 {compiled lreplace: Bug 47ac84309b} {
+ apply {x {
+ ledit 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 ledit ls $a $b {*}$i]
+ set script [list catch $tester m]
+ set script "list \[$script\] \$m"
+ test ledit-6.[incr n] {ledit battery} -body \
+ [list apply [list {ls} $script] $ls] -result $expected
+ }
+ }
+ }
+ }
+}}
+
# cleanup
catch {unset foo}
::tcltest::cleanupTests
diff --git a/tests/lseq.test b/tests/lseq.test
index ffb8a94..7daa59c 100644
--- a/tests/lseq.test
+++ b/tests/lseq.test
@@ -223,6 +223,8 @@ test lseq-3.1 {experiement} {
if {$ans eq {}} {
set ans OK
}
+ unset factor
+ unset l
set ans
} {OK}
@@ -376,13 +378,18 @@ test lseq-3.26 {lsort shimmer} arithSeriesShimmer {
list ${rep-before} $lexical_sort ${rep-after}
} {arithseries {0 1 10 11 12 13 14 15 2 3 4 5 6 7 8 9} arithseries}
-test lseq-3.27 {lreplace shimmer} arithSeriesShimmer {
+test lseq-3.27 {lreplace shimmer} -constraints arithSeriesShimmer -body {
set r [lseq 15 0]
set rep-before [lindex [tcl::unsupported::representation $r] 3]
set lexical_sort [lreplace $r 3 5 A B C]
set rep-after [lindex [tcl::unsupported::representation $r] 3]
list ${rep-before} $lexical_sort ${rep-after}
-} {arithseries {15 14 13 A B C 9 8 7 6 5 4 3 2 1 0} arithseries}
+} -cleanup {
+ unset r
+ unset rep-before
+ unset lexical_sort
+ unset rep-after
+} -result {arithseries {15 14 13 A B C 9 8 7 6 5 4 3 2 1 0} arithseries}
test lseq-3.28 {lreverse bug in ArithSeries} {} {
set r [lseq -5 17 3]
@@ -472,9 +479,41 @@ test lseq-4.3 {TIP examples} {
set res
} {{10 9 8 7 6 5 4 3 2 1} {1 2 3 4 5 6 7 8 9 10} {} {10 8 6 4 2} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} {5.0 10.0 15.0 20.0 25.0} {} {25.0 20.0 15.0 10.0 5.0} {1 3 5 7 9} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} 5 5 5}
+#
+# Ticket 9933cc4d88697f05976accebd31c1e3ba6efe9c6 - lseq corner case
+test lseq-4.4 {lseq corner case} -body {
+ set tcmd {
+ set res {}
+ set s [catch {lindex [lseq 10 100] 0} e]
+ lappend res $s $e
+ set s [catch {lindex [lseq 10 9223372036854775000] 0} e]
+ lappend res $s $e
+ set s [catch {llength [lseq 10 9223372036854775000]} e]
+ lappend res $s $e
+ set s [catch {lindex [lseq 10 2147483647] 0} e]
+ lappend res $s $e
+ set s [catch {llength [lseq 10 2147483647]} e]
+ lappend res $s $e
+ }
+ eval $tcmd
+} -cleanup {
+ unset res
+} -result {0 10 1 {max length of a Tcl list exceeded} 1 {max length of a Tcl list exceeded} 0 10 0 2147483638}
+
+
+# Ticket 99e834bf33 - lseq, lindex end off by one
+
+test lseq-4.5 {lindex off by one} -body {
+ lappend res [eval {lindex [lseq 1 4] end}]
+ lappend res [eval {lindex [lseq 1 4] end-1}]
+} -cleanup {
+ unset res
+} -result {4 3}
+
# cleanup
::tcltest::cleanupTests
+
return
# Local Variables: