From 5cae882ff3da129b6870bfb5b702e27e3f300d9c Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 22 Jun 2016 20:57:18 +0000 Subject: [c95b9fc0e3] Make errorcodes out of level parsing more consistent. --- generic/tclCmdIL.c | 4 ++-- generic/tclProc.c | 2 +- generic/tclVar.c | 3 ++- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 0d35397..c93e593 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1203,7 +1203,7 @@ InfoFrameCmd( levelError: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME", + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", TclGetString(objv[1]), NULL); code = TCL_ERROR; goto done; @@ -1638,7 +1638,7 @@ InfoLevelCmd( levelError: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", TclGetString(objv[1]), NULL); return TCL_ERROR; } diff --git a/generic/tclProc.c b/generic/tclProc.c index 172b860..e8c5955 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -870,7 +870,7 @@ TclObjGetFrame( } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); return -1; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 5574f30..51e2482 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -4938,7 +4938,8 @@ Tcl_UpvarObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(levelObj))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", + TclGetString(levelObj), NULL); return TCL_ERROR; } -- cgit v0.12 From f05e2297802cbc2f12f67acb22ca3680f36d38c8 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 23 Jun 2016 08:20:16 +0000 Subject: [d553228d9f] Stop crashes in [dict update] with low refcount dictionaries. --- generic/tclExecute.c | 4 ++++ tests/dict.test | 7 +++++++ 2 files changed, 11 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d4077f5..38924c6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7706,6 +7706,7 @@ TEBCresume( goto gotError; } } + Tcl_IncrRefCount(dictPtr); if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { TRACE_ERROR(interp); @@ -7718,6 +7719,7 @@ TEBCresume( if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], &valuePtr) != TCL_OK) { TRACE_ERROR(interp); + Tcl_DecrRefCount(dictPtr); goto gotError; } varPtr = LOCAL(duiPtr->varIndices[i]); @@ -7734,10 +7736,12 @@ TEBCresume( duiPtr->varIndices[i]) == NULL) { CACHE_STACK_INFO(); TRACE_ERROR(interp); + Tcl_DecrRefCount(dictPtr); goto gotError; } CACHE_STACK_INFO(); } + TclDecrRefCount(dictPtr); TRACE_APPEND(("OK\n")); NEXT_INST_F(9, 0, 0); diff --git a/tests/dict.test b/tests/dict.test index d5406d0..a6b0cb4 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2048,6 +2048,13 @@ test dict-24.25 {dict map with huge dict (compiled)} { }} 100000 } 166666666600000 +test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} { + # Test crashes on failure + apply {{} { + lassign {} item + dict update item item item two two {} + }} +} {} # cleanup ::tcltest::cleanupTests -- cgit v0.12 From bf46c5018da4ef7a89a2e4c35fa3e9f9080d4d27 Mon Sep 17 00:00:00 2001 From: max Date: Fri, 24 Jun 2016 16:40:30 +0000 Subject: [c30087b04f] Install man pages with permissions 644 instead of 444. --- unix/installManPage | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/installManPage b/unix/installManPage index 4d615bf..1f1cbde 100755 --- a/unix/installManPage +++ b/unix/installManPage @@ -106,7 +106,7 @@ for Target in $Names; do First=$Target sed -e "/man\.macros/r $SrcDir/man.macros" -e "/man\.macros/d" \ $ManPage > $Dir/$First - chmod 444 $Dir/$First + chmod 644 $Dir/$First $Gzip $Dir/$First else ln $SymOrLoc$First$Gz $Dir/$Target$Gz -- cgit v0.12 From cb9a441bb90bab156fe3bcd024cb2490dbd45fb3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 26 Jun 2016 09:00:06 +0000 Subject: (cherry-pick) [c30087b04f] Install man pages with permissions 644 instead of 444. --- unix/installManPage | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/installManPage b/unix/installManPage index 4d615bf..1f1cbde 100755 --- a/unix/installManPage +++ b/unix/installManPage @@ -106,7 +106,7 @@ for Target in $Names; do First=$Target sed -e "/man\.macros/r $SrcDir/man.macros" -e "/man\.macros/d" \ $ManPage > $Dir/$First - chmod 444 $Dir/$First + chmod 644 $Dir/$First $Gzip $Dir/$First else ln $SymOrLoc$First$Gz $Dir/$Target$Gz -- cgit v0.12 From 0cb6ad07c60c0542efc9daa4f6652dc9bc584cc1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 26 Jun 2016 09:03:08 +0000 Subject: Add TCL_NOINLINE macro, useful for micro-optimizations --- generic/tcl.h | 3 +++ 1 file changed, 3 insertions(+) diff --git a/generic/tcl.h b/generic/tcl.h index 3cd90a9..be40368 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -144,6 +144,7 @@ extern "C" { #if defined(__GNUC__) && (__GNUC__ > 2) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # define TCL_NORETURN __attribute__ ((noreturn)) +# define TCL_NOINLINE __attribute__ ((noinline)) # if defined(BUILD_tcl) || defined(BUILD_tk) # define TCL_NORETURN1 __attribute__ ((noreturn)) # else @@ -153,8 +154,10 @@ extern "C" { # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) && (_MSC_VER >= 1310) # define TCL_NORETURN _declspec(noreturn) +# define TCL_NOINLINE __declspec(noinline) # else # define TCL_NORETURN /* nothing */ +# define TCL_NOINLINE /* nothing */ # endif # define TCL_NORETURN1 /* nothing */ #endif -- cgit v0.12 From 6c2f2fec8a334d5889d73e78888036a842496b16 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 27 Jun 2016 10:22:30 +0000 Subject: Make TCL_MAJOR_VERSION/TCL_MINOR_VERSION/TCL_STUB_MAGIC available to Tcl_InitStubs() arguments. Useful for debugging and detection of stub incompatibilities (e.g. for Tcl9) --- generic/tcl.h | 19 +++++++++---------- generic/tclPkg.c | 2 +- generic/tclStubLib.c | 20 +++++++++----------- 3 files changed, 19 insertions(+), 22 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index be40368..6061ea8 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2377,9 +2377,6 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the * stubs tables. - * - * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different - * value since the stubs tables don't match. */ #define TCL_STUB_MAGIC ((int) 0xFCA3BACF) @@ -2392,17 +2389,19 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, */ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, - int exact); + int exact, int magic); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); -/* - * When not using stubs, make it a macro. - */ - -#ifndef USE_TCL_STUBS +#ifdef USE_TCL_STUBS +#define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#else #define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, version, exact) + Tcl_PkgInitStubsCheck(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) #endif /* diff --git a/generic/tclPkg.c b/generic/tclPkg.c index f6e8b20..86777a8 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1895,7 +1895,7 @@ Tcl_PkgInitStubsCheck( { const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); - if (exact && actualVersion) { + if ((exact&1) && actualVersion) { const char *p = version; int count = 0; diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 859cbf9..afabdca 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -24,13 +24,10 @@ const TclIntStubs *tclIntStubsPtr = NULL; const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; /* - * Use our own isDigit to avoid linking to libc on windows + * Use our own ISDIGIT to avoid linking to libc on windows */ -static int isDigit(const int c) -{ - return (c >= '0' && c <= '9'); -} +#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9) /* *---------------------------------------------------------------------- @@ -54,7 +51,8 @@ MODULE_SCOPE const char * Tcl_InitStubs( Tcl_Interp *interp, const char *version, - int exact) + int exact, + int magic) { Interp *iPtr = (Interp *) interp; const char *actualVersion = NULL; @@ -67,8 +65,8 @@ Tcl_InitStubs( * times. [Bug 615304] */ - if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) { - iPtr->result = "interpreter uses an incompatible stubs mechanism"; + if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { + iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; iPtr->freeProc = TCL_STATIC; return NULL; } @@ -77,12 +75,12 @@ Tcl_InitStubs( if (actualVersion == NULL) { return NULL; } - if (exact) { + if (exact&1) { const char *p = version; int count = 0; while (*p) { - count += !isDigit(*p++); + count += !ISDIGIT(*p++); } if (count == 1) { const char *q = actualVersion; @@ -91,7 +89,7 @@ Tcl_InitStubs( while (*p && (*p == *q)) { p++; q++; } - if (*p || isDigit(*q)) { + if (*p || ISDIGIT(*q)) { /* Construct error message */ stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); return NULL; -- cgit v0.12 From 9c058fa5d4a7dd8f3260f31523dea954bb6f2f9f Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 27 Jun 2016 13:44:40 +0000 Subject: [c3d956be5b] Clearer text about positioning of optional arguments. --- doc/proc.n | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/doc/proc.n b/doc/proc.n index 129f4df..fdccaca 100644 --- a/doc/proc.n +++ b/doc/proc.n @@ -34,8 +34,9 @@ one or two fields. If there is only a single field in the specifier then it is the name of the argument; if there are two fields, then the first is the argument name and the second is its default value. Arguments with default values that are followed by non-defaulted -arguments become required arguments. In 8.6 this will be considered an -error. +arguments become required arguments; enough actual arguments must be +supplied to allow all arguments up to and including the last required +formal argument. .PP When \fIname\fR is invoked a local variable will be created for each of the formal arguments to the procedure; its @@ -48,11 +49,14 @@ actual arguments for all the formal arguments that do not have defaults, and there must not be any extra actual arguments. Arguments with default values that are followed by non-defaulted -arguments become required arguments (in 8.6 it will be considered an -error). +arguments become de-facto required arguments, though this may change +in a future version of Tcl; portable code should ensure that all +optional arguments come after all required arguments. +.PP There is one special case to permit procedures with variable numbers of arguments. If the last formal argument has the name -\fBargs\fR, then a call to the procedure may contain more actual arguments +.QW \fBargs\fR , +then a call to the procedure may contain more actual arguments than the procedure has formal arguments. In this case, all of the actual arguments starting at the one that would be assigned to \fBargs\fR are combined into a list (as if the \fBlist\fR command had been used); this combined value @@ -80,6 +84,20 @@ If an error occurs while executing the procedure body, then the procedure-as-a-whole will return that same error. .SH EXAMPLES .PP +This is a procedure that takes two arguments and prints both their sum +and their product. It also returns the string +.QW OK +to the caller as an explicit result. +.PP +.CS +\fBproc\fR printSumProduct {x y} { + set sum [expr {$x + $y}] + set prod [expr {$x * $y}] + puts "sum is $sum, product is $prod" + return "OK" +} +.CE +.PP This is a procedure that accepts arbitrarily many arguments and prints them out, one by one. .PP -- cgit v0.12 From 7a41668df0cca48f94ed89f97164bbb1ddd85e32 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 27 Jun 2016 13:46:15 +0000 Subject: [c3d956be5b] Clearer text about positioning of optional arguments. --- doc/proc.n | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/doc/proc.n b/doc/proc.n index 129f4df..fdccaca 100644 --- a/doc/proc.n +++ b/doc/proc.n @@ -34,8 +34,9 @@ one or two fields. If there is only a single field in the specifier then it is the name of the argument; if there are two fields, then the first is the argument name and the second is its default value. Arguments with default values that are followed by non-defaulted -arguments become required arguments. In 8.6 this will be considered an -error. +arguments become required arguments; enough actual arguments must be +supplied to allow all arguments up to and including the last required +formal argument. .PP When \fIname\fR is invoked a local variable will be created for each of the formal arguments to the procedure; its @@ -48,11 +49,14 @@ actual arguments for all the formal arguments that do not have defaults, and there must not be any extra actual arguments. Arguments with default values that are followed by non-defaulted -arguments become required arguments (in 8.6 it will be considered an -error). +arguments become de-facto required arguments, though this may change +in a future version of Tcl; portable code should ensure that all +optional arguments come after all required arguments. +.PP There is one special case to permit procedures with variable numbers of arguments. If the last formal argument has the name -\fBargs\fR, then a call to the procedure may contain more actual arguments +.QW \fBargs\fR , +then a call to the procedure may contain more actual arguments than the procedure has formal arguments. In this case, all of the actual arguments starting at the one that would be assigned to \fBargs\fR are combined into a list (as if the \fBlist\fR command had been used); this combined value @@ -80,6 +84,20 @@ If an error occurs while executing the procedure body, then the procedure-as-a-whole will return that same error. .SH EXAMPLES .PP +This is a procedure that takes two arguments and prints both their sum +and their product. It also returns the string +.QW OK +to the caller as an explicit result. +.PP +.CS +\fBproc\fR printSumProduct {x y} { + set sum [expr {$x + $y}] + set prod [expr {$x * $y}] + puts "sum is $sum, product is $prod" + return "OK" +} +.CE +.PP This is a procedure that accepts arbitrarily many arguments and prints them out, one by one. .PP -- cgit v0.12 From 16dc4253187f0ef49c09688cd3a2085120328302 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 27 Jun 2016 14:27:43 +0000 Subject: [dd260aaf72] Allow the -dictionary option to be read from a pushed transform. --- doc/zlib.n | 18 ++++++++++++------ generic/tclZlib.c | 36 +++++++++++++++--------------------- tests/zlib.test | 20 ++++++++++++++++++++ 3 files changed, 47 insertions(+), 27 deletions(-) diff --git a/doc/zlib.n b/doc/zlib.n index 9f3078d..fd29e0d 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -174,7 +174,11 @@ to the \fBzlib push\fR command: .VS "TIP 400" Sets the compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. Not valid for transformations that -work with gzip-format data. +work with gzip-format data. The dictionary should consist of strings (byte +sequences) that are likely to be encountered later in the data to be compressed, +with the most commonly used strings preferably put towards the end of the +dictionary. Tcl provides no mechanism for choosing a good such dictionary for +a particular data sequence. .VE .TP \fB\-header\fI dictionary\fR @@ -207,11 +211,13 @@ compression algorithm depends on what format is being produced or consumed. .TP \fB\-dictionary\fI binData\fR .VS "TIP 400" -This read-write options gets or sets the compression dictionary to use when -working with compressing or decompressing the data to be \fIbinData\fR. It is -not valid for transformations that work with gzip-format data, and should not -normally be set on compressing transformations other than at the point where -the transformation is stacked. +This read-write options gets or sets the initial compression dictionary to use +when working with compressing or decompressing the data to be \fIbinData\fR. +It is not valid for transformations that work with gzip-format data, and should +not normally be set on compressing transformations other than at the point where +the transformation is stacked. Note that this cannot be used to get the +current active compression dictionary mid-stream, as that information is not +exposed by the underlying library. .VE .TP \fB\-flush\fI type\fR diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 691d57a..dac47cf 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2906,9 +2906,9 @@ ZlibTransformClose( } } } while (e != Z_STREAM_END); - e = deflateEnd(&cd->outStream); + (void) deflateEnd(&cd->outStream); } else { - e = inflateEnd(&cd->inStream); + (void) inflateEnd(&cd->inStream); } /* @@ -3344,10 +3344,13 @@ ZlibTransformGetOption( Tcl_DStringAppendElement(dsPtr, ""); } } else { - int len; - const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); + if (cd->compDictObj) { + int len; + const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); - Tcl_DStringAppend(dsPtr, str, len); + Tcl_DStringAppend(dsPtr, str, len); + } + return TCL_OK; } } @@ -3549,7 +3552,6 @@ ZlibStackChannelTransform( ZlibChannelData *cd = ckalloc(sizeof(ZlibChannelData)); Tcl_Channel chan; int wbits = 0; - int e; if (mode != TCL_ZLIB_STREAM_DEFLATE && mode != TCL_ZLIB_STREAM_INFLATE) { Tcl_Panic("unknown mode: %d", mode); @@ -3603,43 +3605,35 @@ ZlibStackChannelTransform( */ if (mode == TCL_ZLIB_STREAM_INFLATE) { - e = inflateInit2(&cd->inStream, wbits); - if (e != Z_OK) { + if (inflateInit2(&cd->inStream, wbits) != Z_OK) { goto error; } cd->inAllocated = DEFAULT_BUFFER_SIZE; cd->inBuffer = ckalloc(cd->inAllocated); if (cd->flags & IN_HEADER) { - e = inflateGetHeader(&cd->inStream, &cd->inHeader.header); - if (e != Z_OK) { + if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) { goto error; } } if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) { - e = SetInflateDictionary(&cd->inStream, cd->compDictObj); - if (e != Z_OK) { + if (SetInflateDictionary(&cd->inStream, cd->compDictObj) != Z_OK) { goto error; } - TclDecrRefCount(cd->compDictObj); - cd->compDictObj = NULL; } } else { - e = deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits, - MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); - if (e != Z_OK) { + if (deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits, + MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY) != Z_OK) { goto error; } cd->outAllocated = DEFAULT_BUFFER_SIZE; cd->outBuffer = ckalloc(cd->outAllocated); if (cd->flags & OUT_HEADER) { - e = deflateSetHeader(&cd->outStream, &cd->outHeader.header); - if (e != Z_OK) { + if (deflateSetHeader(&cd->outStream, &cd->outHeader.header) != Z_OK) { goto error; } } if (cd->compDictObj) { - e = SetDeflateDictionary(&cd->outStream, cd->compDictObj); - if (e != Z_OK) { + if (SetDeflateDictionary(&cd->outStream, cd->compDictObj) != Z_OK) { goto error; } } diff --git a/tests/zlib.test b/tests/zlib.test index 968469d..c9e5f10 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -401,6 +401,26 @@ test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup { } -cleanup { removeFile $file } -result 57647 +test zlib-8.17 {Bug dd260aaf: fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push inflate $inSide + zlib push deflate $outSide + list [chan configure $inSide -dictionary] [chan configure $outSide -dictionary] +} -cleanup { + catch {close $inSide} + catch {close $outSide} +} -result {{} {}} +test zlib-8.18 {Bug dd260aaf: fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push inflate $inSide -dictionary "one two" + zlib push deflate $outSide -dictionary "one two" + list [chan configure $inSide -dictionary] [chan configure $outSide -dictionary] +} -cleanup { + catch {close $inSide} + catch {close $outSide} +} -result {{one two} {one two}} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From bf285438a2b30acf74d19b010139b66f5e2fb528 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 27 Jun 2016 15:16:04 +0000 Subject: Streamline comment parsing. --- generic/tclParse.c | 67 +++++++++++++++++++++++++++--------------------------- 1 file changed, 33 insertions(+), 34 deletions(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index 95abc45..4974c87 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -167,6 +167,8 @@ static int ParseTokens(const char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr); static int ParseWhiteSpace(const char *src, int numBytes, int *incompletePtr, char *typePtr); +static int ParseAllWhiteSpace(const char *src, int numBytes, + int *incompletePtr); /* *---------------------------------------------------------------------- @@ -733,23 +735,32 @@ ParseWhiteSpace( *---------------------------------------------------------------------- */ -int -TclParseAllWhiteSpace( +static int +ParseAllWhiteSpace( const char *src, /* First character to parse. */ - int numBytes) /* Max number of byes to scan */ + int numBytes, /* Max number of byes to scan */ + int *incompletePtr) /* Set true if parse is incomplete. */ { - int dummy; char type; const char *p = src; do { - int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type); + int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type); p += scanned; numBytes -= scanned; } while (numBytes && (*p == '\n') && (p++, --numBytes)); return (p-src); } + +int +TclParseAllWhiteSpace( + const char *src, /* First character to parse. */ + int numBytes) /* Max number of byes to scan */ +{ + int dummy; + return ParseAllWhiteSpace(src, numBytes, &dummy); +} /* *---------------------------------------------------------------------- @@ -1021,17 +1032,12 @@ ParseComment( * command. */ { register const char *p = src; + int incomplete = parsePtr->incomplete; while (numBytes) { - char type; - int scanned; - - do { - scanned = ParseWhiteSpace(p, numBytes, - &parsePtr->incomplete, &type); - p += scanned; - numBytes -= scanned; - } while (numBytes && (*p == '\n') && (p++,numBytes--)); + int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); + p += scanned; + numBytes -= scanned; if ((numBytes == 0) || (*p != '#')) { break; @@ -1039,36 +1045,29 @@ ParseComment( if (parsePtr->commentStart == NULL) { parsePtr->commentStart = p; } - + + p++; + numBytes--; while (numBytes) { + if (*p == '\n') { + p++; + numBytes--; + break; + } if (*p == '\\') { - scanned = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete, - &type); - if (scanned) { - p += scanned; - numBytes -= scanned; - } else { - /* - * General backslash substitution in comments isn't part - * of the formal spec, but test parse-15.47 and history - * indicate that it has been the de facto rule. Don't - * change it now. - */ - - TclParseBackslash(p, numBytes, &scanned, NULL); - p += scanned; - numBytes -= scanned; - } - } else { p++; numBytes--; - if (p[-1] == '\n') { + if (numBytes == 0) { break; } } + incomplete = (*p == '\n'); + p++; + numBytes--; } parsePtr->commentSize = p - parsePtr->commentStart; } + parsePtr->incomplete = incomplete; return (p - src); } -- cgit v0.12 From cc2f6f6a7d3968e4411d45a4d5ee62b390bb3f4e Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 27 Jun 2016 19:01:34 +0000 Subject: Stop parsing white space where there cannot be any. --- generic/tclParse.c | 69 ++++++++++++++++++++++-------------------------------- 1 file changed, 28 insertions(+), 41 deletions(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index 4974c87..3372318 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -294,12 +294,18 @@ Tcl_ParseCommand( } } + /* Jump to where we check for command termination */ + + parsePtr->commandStart = src; + type = CHAR_TYPE(*src); + scanned = 1; + goto start; + /* * The following loop parses the words of the command, one word in each * iteration through the loop. */ - parsePtr->commandStart = src; while (1) { int expandWord = 0; @@ -312,23 +318,6 @@ Tcl_ParseCommand( tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->type = TCL_TOKEN_WORD; - /* - * Skip white space before the word. Also skip a backslash-newline - * sequence: it should be treated just like white space. - */ - - scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); - src += scanned; - numBytes -= scanned; - if (numBytes == 0) { - parsePtr->term = src; - break; - } - if ((type & terminators) != 0) { - parsePtr->term = src; - src++; - break; - } tokenPtr->start = src; parsePtr->numTokens++; parsePtr->numWords++; @@ -555,12 +544,10 @@ Tcl_ParseCommand( */ scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); - if (scanned) { - src += scanned; - numBytes -= scanned; - continue; - } + src += scanned; + numBytes -= scanned; + start: if (numBytes == 0) { parsePtr->term = src; break; @@ -570,30 +557,30 @@ Tcl_ParseCommand( src++; break; } - if (src[-1] == '"') { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-quote", -1)); - } - parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; - } else { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-brace", -1)); + if (scanned == 0) { + if (src[-1] == '"') { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-quote", -1)); + } + parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; + } else { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-brace", -1)); + } + parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; } - parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; + parsePtr->term = src; + error: + Tcl_FreeParse(parsePtr); + parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; + return TCL_ERROR; } - parsePtr->term = src; - goto error; } parsePtr->commandSize = src - parsePtr->commandStart; return TCL_OK; - - error: - Tcl_FreeParse(parsePtr); - parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; - return TCL_ERROR; } /* -- cgit v0.12 From 73124928ba9d5134012c0c7bdfcd02dcf876d7cf Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 27 Jun 2016 20:29:46 +0000 Subject: Re-order loop for fewer gotos. --- generic/tclParse.c | 82 ++++++++++++++++++++++++------------------------------ 1 file changed, 36 insertions(+), 46 deletions(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index 3372318..568024b 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -294,21 +294,49 @@ Tcl_ParseCommand( } } - /* Jump to where we check for command termination */ - - parsePtr->commandStart = src; - type = CHAR_TYPE(*src); - scanned = 1; - goto start; - /* * The following loop parses the words of the command, one word in each * iteration through the loop. */ + parsePtr->commandStart = src; + type = CHAR_TYPE(*src); + scanned = 1; /* Can't have missing whitepsace before first word. */ while (1) { int expandWord = 0; + /* Are we at command termination? */ + + if ((numBytes == 0) || (type & terminators) != 0) { + parsePtr->term = src; + parsePtr->commandSize = src + (numBytes != 0) + - parsePtr->commandStart; + return TCL_OK; + } + + /* Are we missing white space after previous word? */ + + if (scanned == 0) { + if (src[-1] == '"') { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-quote", -1)); + } + parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; + } else { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-brace", -1)); + } + parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; + } + parsePtr->term = src; + error: + Tcl_FreeParse(parsePtr); + parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; + return TCL_ERROR; + } + /* * Create the token for the word. */ @@ -537,50 +565,12 @@ Tcl_ParseCommand( tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } - /* - * Do two additional checks: (a) make sure we're really at the end of - * a word (there might have been garbage left after a quoted or braced - * word), and (b) check for the end of the command. - */ + /* Parse the whitespace between words. */ scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); src += scanned; numBytes -= scanned; - - start: - if (numBytes == 0) { - parsePtr->term = src; - break; - } - if ((type & terminators) != 0) { - parsePtr->term = src; - src++; - break; - } - if (scanned == 0) { - if (src[-1] == '"') { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-quote", -1)); - } - parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; - } else { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-brace", -1)); - } - parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; - } - parsePtr->term = src; - error: - Tcl_FreeParse(parsePtr); - parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; - return TCL_ERROR; - } } - - parsePtr->commandSize = src - parsePtr->commandStart; - return TCL_OK; } /* -- cgit v0.12