-- cgit v0.12 From 9372c6c29f2b15708d4b7c57d7d252bd7fa5cca6 Mon Sep 17 00:00:00 2001 From: avl Date: Sun, 5 Mar 2017 11:22:33 +0000 Subject: cherrypick 3bcf97f766: array index syntax done. ${...} not yet complete wrt backslashes. --- generic/tclParse.c | 23 ++++++++++++++++++----- generic/tclParse.h | 2 ++ 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index 9b801a3..10f016d 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -95,7 +95,7 @@ const char tclCharTypeTable[] = { TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_SPACE, TYPE_NORMAL, TYPE_QUOTE, TYPE_NORMAL, TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_CLOSE_PAREN, TYPE_NORMAL, TYPE_NORMAL, + TYPE_OPEN_PAREN, TYPE_CLOSE_PAREN, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, @@ -1366,7 +1366,7 @@ Tcl_ParseVarName( { Tcl_Token *tokenPtr; register const char *src; - int varIndex; + int varIndex, braceCount = 0; unsigned array; if ((numBytes == 0) || (start == NULL)) { @@ -1419,15 +1419,20 @@ Tcl_ParseVarName( */ if (*src == '{') { + char ch; src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; - while (numBytes && (*src != '}')) { + ch = *src; + while (numBytes && (braceCount>0 || ch != '}')) { + if (ch == '{') { braceCount++; } + else if (ch == '}') { braceCount--; } numBytes--; src++; + ch= *src; } if (numBytes == 0) { if (parsePtr->interp != NULL) { @@ -1483,11 +1488,11 @@ Tcl_ParseVarName( * any number of substitutions. */ - if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, + if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_BAD_ARRAY_INDEX, TCL_SUBST_ALL, parsePtr)) { goto error; } - if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){ + if ((parsePtr->term == src+numBytes)){ if (parsePtr->interp != NULL) { Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( "missing )", -1)); @@ -1496,6 +1501,14 @@ Tcl_ParseVarName( parsePtr->term = src; parsePtr->incomplete = 1; goto error; + } else if ((*parsePtr->term != ')')){ + if (parsePtr->interp != NULL) { + Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( + "invalid char in array index", -1)); + } + parsePtr->errorType = TCL_PARSE_SYNTAX; + parsePtr->term = src; + goto error; } src = parsePtr->term + 1; } diff --git a/generic/tclParse.h b/generic/tclParse.h index 20c609c..a836147 100644 --- a/generic/tclParse.h +++ b/generic/tclParse.h @@ -11,6 +11,8 @@ #define TYPE_CLOSE_PAREN 0x10 #define TYPE_CLOSE_BRACK 0x20 #define TYPE_BRACE 0x40 +#define TYPE_OPEN_PAREN 0x80 +#define TYPE_BAD_ARRAY_INDEX (TYPE_OPEN_PAREN|TYPE_CLOSE_PAREN|TYPE_QUOTE|TYPE_BRACE) #define CHAR_TYPE(c) (tclCharTypeTable+128)[(int)(c)] -- cgit v0.12 From a457b16dfc3bd4a4db9171364cd2a5ab04392bb8 Mon Sep 17 00:00:00 2001 From: avl Date: Sun, 5 Mar 2017 19:38:43 +0000 Subject: Deal with backslashes in ${...}, change "char" to "character" in error, fix tests. --- generic/tclParse.c | 18 +++++++++++++----- tests/parse.test | 6 +++--- tests/parseExpr.test | 4 ++-- 3 files changed, 18 insertions(+), 10 deletions(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index 10f016d..372ec92 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1366,7 +1366,7 @@ Tcl_ParseVarName( { Tcl_Token *tokenPtr; register const char *src; - int varIndex, braceCount = 0; + int varIndex; unsigned array; if ((numBytes == 0) || (start == NULL)) { @@ -1419,7 +1419,7 @@ Tcl_ParseVarName( */ if (*src == '{') { - char ch; + char ch; int braceCount = 0; src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; @@ -1428,8 +1428,16 @@ Tcl_ParseVarName( ch = *src; while (numBytes && (braceCount>0 || ch != '}')) { - if (ch == '{') { braceCount++; } - else if (ch == '}') { braceCount--; } + switch (ch) { + case '{': braceCount++; break; + case '}': braceCount--; break; + case '\\': + /* if 2 or more left, consume 2, else consume + just the \ and let it run into the end */ + if (numBytes > 1) { + src++; numBytes--; + } + } numBytes--; src++; ch= *src; @@ -1504,7 +1512,7 @@ Tcl_ParseVarName( } else if ((*parsePtr->term != ')')){ if (parsePtr->interp != NULL) { Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "invalid char in array index", -1)); + "invalid character in array index", -1)); } parsePtr->errorType = TCL_PARSE_SYNTAX; parsePtr->term = src; diff --git a/tests/parse.test b/tests/parse.test index 287c392..e031327 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -601,8 +601,8 @@ test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} testparser { testparser {${..[]b}cd} 0 } {- {${..[]b}cd} 1 word {${..[]b}cd} 3 variable {${..[]b}} 1 text {..[]b} 0 text cd 0 {}} test parse-12.7 {Tcl_ParseVarName procedure, braced variable name} testparser { - testparser "\$\{\{\} " 0 -} {- \$\{\{\}\ 1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}} + testparser "\$\{\{\\\\\}\} " 0 +} {- {${{\\}} } 1 word {${{\\}}} 2 variable {${{\\}}} 1 text {{\\}} 0 {}} test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} testparser { list [catch {testparser "$\{abc" 0} msg] $msg $::errorInfo } {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\$\\\{abc\"\ 0\"} @@ -797,7 +797,7 @@ test parse-15.16 {CommandComplete procedure} { } 1 test parse-15.17 {CommandComplete procedure} { info complete {a b "c $dd("} -} 0 +} 1 test parse-15.18 {CommandComplete procedure} { info complete {a b "c \"} } 0 diff --git a/tests/parseExpr.test b/tests/parseExpr.test index 47dbec5..e0c979c 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -917,8 +917,8 @@ test parseExpr-21.43 {error message} -body { in expression \"...8901234567890*\"foobar\$\{abcdefghijklmnopqrstuv...\"" test parseExpr-21.44 {error message} -body { expr {123456789012345678901234567890*"foo$bar(abcdefghijklmnopqrstuvwxyz"} -} -returnCodes error -result {missing ) -in expression "...8901234567890*"foo$bar(abcdefghijklmnopqrstuv..."} +} -returnCodes error -result {invalid character in array index +in expression "...8901234567890*"foo$bar(abcdefghijklmnopqrstu..."} test parseExpr-21.45 {error message} -body { expr {123456789012345678901234567890*"foo$bar([{}abcdefghijklmnopqrstuvwxyz])"} } -returnCodes error -result {extra characters after close-brace -- cgit v0.12 From 85c05d7a3d1760c35dcf594502b7816f35a443da Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Sep 2022 15:39:02 +0000 Subject: Include TYPE_OPEN_PAREN in the comment. --- generic/tclParse.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclParse.c b/generic/tclParse.c index 18773a5..af507e9 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -33,6 +33,7 @@ * meaning in ParseTokens: backslash, dollar sign, or * open bracket. * TYPE_QUOTE - Character is a double quote. + * TYPE_OPEN_PAREN - Character is a left parenthesis. * TYPE_CLOSE_PAREN - Character is a right parenthesis. * TYPE_CLOSE_BRACK - Character is a right square bracket. * TYPE_BRACE - Character is a curly brace (either left or right). -- cgit v0.12 From b01f9536cb1fe19d6b97c9a81b4dac4fb98dd5dd Mon Sep 17 00:00:00 2001 From: griffin Date: Fri, 30 Sep 2022 00:03:55 +0000 Subject: Fix various issues with refCounts. --- generic/tclArithSeries.c | 6 ++---- generic/tclCmdAH.c | 7 +++++++ generic/tclListObj.c | 2 -- tests/lseq.test | 14 ++++++++++++-- 4 files changed, 21 insertions(+), 8 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 61b4a9b..ee201fa 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -392,6 +392,7 @@ TclArithSeriesObjStep( } else { *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); } + Tcl_IncrRefCount(*stepObj); return TCL_OK; } @@ -436,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; } @@ -722,11 +724,8 @@ 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))) { @@ -857,7 +856,6 @@ TclArithSeriesGetElements( } return TCL_ERROR; } - Tcl_IncrRefCount(objv[i]); } } } else { 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/tclListObj.c b/generic/tclListObj.c index d18ad59..598ff6f 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2641,7 +2641,6 @@ TclLindexFlat( } if (i==0) { TclArithSeriesObjIndex(listObj, index, &elemObj); - Tcl_IncrRefCount(elemObj); } else if (index > 0) { Tcl_DecrRefCount(elemObj); TclNewObj(elemObj); @@ -3304,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/tests/lseq.test b/tests/lseq.test index 518a7bb..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] @@ -499,11 +506,14 @@ test lseq-4.4 {lseq corner case} -body { 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: -- cgit v0.12 From f9753a5e4109e31176bc1da885ff5ec23839662b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Sep 2022 11:30:11 +0000 Subject: Replace incorrect use of TclGetNumberFromObj --- generic/tclArithSeries.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 1302780..51f27b2 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -307,12 +307,9 @@ TclNewArithSeriesObj( assignNumber(useDoubles, &end, &dend, endObj); } if (lenObj) { - int tcl_number_type; - Tcl_WideInt *valuePtr; - if (TclGetNumberFromObj(interp, lenObj, (ClientData*)&valuePtr, &tcl_number_type) != TCL_OK) { + if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) { return TCL_ERROR; } - len = *valuePtr; } if (startObj && endObj) { -- cgit v0.12 From 3f371a5084c05daba396645abd9a25deb3d023d1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Oct 2022 15:56:08 +0000 Subject: =?UTF-8?q?Fix=20g++=20warning:=20tclEvent.c:1519:10:=20warning:?= =?UTF-8?q?=20declaration=20of=20=E2=80=98enum=20Tcl=5FVwaitObjCmd(void*,?= =?UTF-8?q?=20Tcl=5FInterp*,=20int,=20Tcl=5FObj*=20const*)::options?= =?UTF-8?q?=E2=80=99=20shadows=20a=20previous=20local=20[-Wshadow]?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclEvent.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 183ac82..1e2e7bf 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1511,12 +1511,12 @@ Tcl_VwaitObjCmd( Tcl_Channel chan; Tcl_WideInt diff = -1; VwaitItem localItems[32], *vwaitItems = localItems; - static const char *const options[] = { + static const char *const vWaitOptionStrings[] = { "-all", "-extended", "-nofileevents", "-noidleevents", "-notimerevents", "-nowindowevents", "-readable", "-timeout", "-variable", "-writable", "--", NULL }; - enum options { + enum vWaitOptions { OPT_ALL, OPT_EXTD, OPT_NO_FEVTS, OPT_NO_IEVTS, OPT_NO_TEVTS, OPT_NO_WEVTS, OPT_READABLE, OPT_TIMEOUT, OPT_VARIABLE, OPT_WRITABLE, OPT_LAST @@ -1541,7 +1541,7 @@ Tcl_VwaitObjCmd( if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], vWaitOptionStrings, "option", 0, &index) != TCL_OK) { result = TCL_ERROR; goto done; @@ -1570,7 +1570,7 @@ Tcl_VwaitObjCmd( needArg: Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "argument required for \"%s\"", options[index])); + "argument required for \"%s\"", vWaitOptionStrings[index])); Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", NULL); result = TCL_ERROR; goto done; -- cgit v0.12