diff options
author | evilotto <evilotto> | 2014-11-26 18:17:34 (GMT) |
---|---|---|
committer | evilotto <evilotto> | 2014-11-26 18:17:34 (GMT) |
commit | 5cd6e3655aa18d12fd25de99de591b2e2074049b (patch) | |
tree | b496abc8bdbca86c65cdc20e6d21f2bc471206c2 | |
parent | 6eb9ac605e8119a21ec7d047ba0da0375559d527 (diff) | |
parent | 33eb2510ff53b7fd3b32ea1c84b4ef85d00c10f8 (diff) | |
download | tcl-jcr_notifier_poll.zip tcl-jcr_notifier_poll.tar.gz tcl-jcr_notifier_poll.tar.bz2 |
Merge from trunkjcr_notifier_poll
84 files changed, 3138 insertions, 1550 deletions
@@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6.2 source distribution. + This is the Tcl 8.6.3 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. @@ -8303,11 +8303,11 @@ reported usage of large expressions (porter) Many optmizations, improvements, and tightened stack management in bytecode. ---- Released 8.6.1, September 20, 2013 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.1, September 20, 2013 --- http://core.tcl.tk/tcl/ for details 2013-09-27 (enhancement) improved ::env synchronization (fellows) -2013-10-20 (bug fix)[2835313] segfault from +2013-10-20 (bug fix)[2835313] segfault from [apply {{} {while 1 {a {*}[return -level 0 -code continue]}}}] (fellows) 2013-10-22 (bug fix)[3556215] [scan %E%G%X] support (fellows) @@ -8451,4 +8451,43 @@ include ::oo::class (fellows) 2014-08-25 (TIP 429) New command [string cat] (leitgeb,ferrieux) ---- Released 8.6.2, August 27, 2014 --- http://core.tcl.tk/tcl/ for details +--- Released 8.6.2, August 27, 2014 --- http://core.tcl.tk/tcl/ for details + +2014-08-28 (bug)[b9e1a3] Correct Method Search Order (nadkarni,fellows) +=> TclOO 1.0.3 + +2014-09-05 (bug)[ccc2c2] Regression [lreplace {} 1 1] (bron,fellows) + +2014-09-08 (bug)<oo-1.18.2> Crash regression in [oo::class destroy] (porter) + +2014-09-09 (bug)[84af11] Regress [regsub -all {\(.*} a(b) {}] (fellows) + +2014-09-10 (bug)[cee90e] [try {} on ok {} - on return {} {}] panic (porter) + +2014-09-20 (feature) [tcl::unsupported::getbytecode] disassember (fellows) + +2014-09-27 (enhancement) [string cat] bytecode optimization (leitgeb,ferrieux) + +2014-09-27 (bug)[82521b] segfault in mangled bytecode (ogilvie,sofer) + +2014-10-02 (bug)[bc5b79] Hang in some [read]s of limited size (rogers,porter) + +2014-10-03 (bug)[bc1a96] segfault in [array set] of traced array (tab,porter) + +2014-10-08 (bug)[59a2e7] MSVC14 compile support (dower,nijtmans) + +2014-10-10 (bug)[ed29c4] [fcopy] treats [blocked] as error (rowen,porter) + +2014-10-10 (bug)[bf7135] regression in Tcl_Write() interface (porter) + +2014-10-18 (bug)[10dc6d] fix [gets] on non-blocking channels (fassel,porter) + +2014-10-26 Support for Windows 10 (nijtmans) + +2014-10-31 (bug)[dcc034] restore [open comX: r+] (lll,nijtmans) + +2014-11-05 (bug)[214cc0] Restore [lappend v] return value (sayers,porter) + +2014-11-06 (bug)[5adc35] Stop forcing EOF to be permanent (porter) + +--- Released 8.6.3, November 12, 2014 --- http://core.tcl.tk/tcl/ for details diff --git a/doc/TraceCmd.3 b/doc/TraceCmd.3 index 1244576..db2f5d5 100644 --- a/doc/TraceCmd.3 +++ b/doc/TraceCmd.3 @@ -86,11 +86,14 @@ operation is being performed on the command. The bit \fBTCL_TRACE_DESTROYED\fR will be set in \fIflags\fR if the trace is about to be destroyed; this information may be useful to \fIproc\fR so that it can clean up its own internal data structures (see the section -\fBTCL_TRACE_DESTROYED\fR below for more details). Lastly, the bit -\fBTCL_INTERP_DESTROYED\fR will be set if the entire interpreter is being -destroyed. When this bit is set, \fIproc\fR must be especially -careful in the things it does (see the section \fBTCL_INTERP_DESTROYED\fR -below). +\fBTCL_TRACE_DESTROYED\fR below for more details). Because the +deletion of commands can take place as part of the deletion of the interp +that contains them, \fIproc\fR must be careful about checking what +the passed in \fIinterp\fR value can be called upon to do. +The routine \fBTcl_InterpDeleted\fR is an important tool for this. +When \fBTcl_InterpDeleted\fR returns 1, \fIproc\fR will not be able +to invoke any scripts in \fIinterp\fR. The function of \fIproc\fR +in that circumstance is limited to the cleanup of its own data structures. .PP \fBTcl_UntraceCommand\fR may be used to remove a trace. If the command specified by \fIinterp\fR, \fIcmdName\fR, and \fIflags\fR has @@ -123,7 +126,8 @@ traces for a given command that have the same \fIproc\fR. .PP During rename traces, the command being renamed is visible with both names simultaneously, and the command still exists during delete -traces (if \fBTCL_INTERP_DESTROYED\fR is not set). However, there is no +traces, unless the interp that contains it is being deleted. +However, there is no mechanism for signaling that an error occurred in a trace procedure, so great care should be taken that errors do not get silently lost. .SH "MULTIPLE TRACES" @@ -142,22 +146,5 @@ rename the command, the last renaming takes precedence. In a delete callback to \fIproc\fR, the \fBTCL_TRACE_DESTROYED\fR bit is set in \fIflags\fR. .\" Perhaps need some more comments here? - DKF -.SH "TCL_INTERP_DESTROYED" -.PP -When an interpreter is destroyed, unset traces are called for -all of its commands. -The \fBTCL_INTERP_DESTROYED\fR bit will be set in the \fIflags\fR -argument passed to the trace procedures. -Trace procedures must be extremely careful in what they do if -the \fBTCL_INTERP_DESTROYED\fR bit is set. -It is not safe for the procedures to invoke any Tcl procedures -on the interpreter, since its state is partially deleted. -All that trace procedures should do under these circumstances is -to clean up and free their own internal data structures. -.SH BUGS -.PP -Tcl does not do any error checking to prevent trace procedures -from misusing the interpreter during traces with \fBTCL_INTERP_DESTROYED\fR -set. .SH KEYWORDS clientData, trace, command @@ -361,18 +361,17 @@ may cause this error. A BREAK condition has been detected by your UART (see above). .SH "PORTABILITY ISSUES" .TP -\fBWindows \fR(all versions) +\fBWindows \fR . Valid values for \fIfileName\fR to open a serial port are of the form -\fBcom\fIX\fB:\fR, where \fIX\fR is a number, generally from 1 to 4. -This notation only works for serial ports from 1 to 9, if the system -happens to have more than four. An attempt to open a serial port that +\fBcom\fIX\fB\fR, where \fIX\fR is a number, generally from 1 to 9. +A legacy form accepted as well is \fBcom\fIX\fB:\fR. This notation only +works for serial ports from 1 to 9. An attempt to open a serial port that does not exist or has a number greater than 9 will fail. An alternate -form of opening serial ports is to use the filename \fB\e\e.\ecomX\fR, -where X is any number that corresponds to a serial port; please note -that this method is considerably slower on Windows 95 and Windows 98. -.TP -\fBWindows NT\fR +form of opening serial ports is to use the filename \fB//./comX\fR, +where X is any number that corresponds to a serial port. +.RS +.PP . When running Tcl interactively, there may be some strange interactions between the real console, if one is present, and a command pipeline that uses @@ -380,45 +379,11 @@ standard input or output. If a command pipeline is opened for reading, some of the lines entered at the console will be sent to the command pipeline and some will be sent to the Tcl evaluator. If a command pipeline is opened for writing, keystrokes entered into the console are not visible until the -pipe is closed. This behavior occurs whether the command pipeline is -executing 16-bit or 32-bit applications. These problems only occur because -both Tcl and the child application are competing for the console at -the same time. If the command pipeline is started from a script, so that Tcl -is not accessing the console, or if the command pipeline does not use -standard input or output, but is redirected from or to a file, then the -above problems do not occur. -.TP -\fBWindows 95\fR -. -A command pipeline that executes a 16-bit DOS application cannot be opened -for both reading and writing, since 16-bit DOS applications that receive -standard input from a pipe and send standard output to a pipe run -synchronously. Command pipelines that do not execute 16-bit DOS -applications run asynchronously and can be opened for both reading and -writing. -.RS -.PP -When running Tcl interactively, there may be some strange interactions -between the real console, if one is present, and a command pipeline that uses -standard input or output. If a command pipeline is opened for reading from -a 32-bit application, some of the keystrokes entered at the console will be -sent to the command pipeline and some will be sent to the Tcl evaluator. If -a command pipeline is opened for writing to a 32-bit application, no output -is visible on the console until the pipe is closed. These problems only -occur because both Tcl and the child application are competing for the -console at the same time. If the command pipeline is started from a script, -so that Tcl is not accessing the console, or if the command pipeline does -not use standard input or output, but is redirected from or to a file, then -the above problems do not occur. -.PP -Whether or not Tcl is running interactively, if a command pipeline is opened -for reading from a 16-bit DOS application, the call to \fBopen\fR will not -return until end-of-file has been received from the command pipeline's -standard output. If a command pipeline is opened for writing to a 16-bit DOS -application, no data will be sent to the command pipeline's standard output -until the pipe is actually closed. This problem occurs because 16-bit DOS -applications are run synchronously, as described above. -.RE +pipe is closed. These problems only occur because both Tcl and the child +application are competing for the console at the same time. If the command +pipeline is started from a script, so that Tcl is not accessing the console, +or if the command pipeline does not use standard input or output, but is +redirected from or to a file, then the above problems do not occur. .TP \fBUnix\fR\0\0\0\0\0\0\0 . diff --git a/generic/tcl.h b/generic/tcl.h index 7531242..fc477f2 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 3 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.2" +#define TCL_PATCH_LEVEL "8.6.3" /* *---------------------------------------------------------------------------- diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index ae61e85..cda1f38 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -31,7 +31,7 @@ * until Tcl uses config.h properly. */ -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__) +#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) typedef unsigned long caddr_t; #endif diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2a334c4..361ed49 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -840,7 +840,9 @@ Tcl_CreateInterp(void) */ Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", - Tcl_DisassembleObjCmd, NULL, NULL); + Tcl_DisassembleObjCmd, INT2PTR(0), NULL); + Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode", + Tcl_DisassembleObjCmd, INT2PTR(1), NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index d1d7a80..18f4564 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -26,14 +26,23 @@ static void FreeDictUpdateInfo(ClientData clientData); static void PrintDictUpdateInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleDictUpdateInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static ClientData DupForeachInfo(ClientData clientData); static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleForeachInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static void PrintNewForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleNewForeachInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); @@ -49,21 +58,24 @@ const AuxDataType tclForeachInfoType = { "ForeachInfo", /* name */ DupForeachInfo, /* dupProc */ FreeForeachInfo, /* freeProc */ - PrintForeachInfo /* printProc */ + PrintForeachInfo, /* printProc */ + DisassembleForeachInfo /* disassembleProc */ }; const AuxDataType tclNewForeachInfoType = { "NewForeachInfo", /* name */ DupForeachInfo, /* dupProc */ FreeForeachInfo, /* freeProc */ - PrintNewForeachInfo /* printProc */ + PrintNewForeachInfo, /* printProc */ + DisassembleNewForeachInfo /* disassembleProc */ }; const AuxDataType tclDictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ FreeDictUpdateInfo, /* freeProc */ - PrintDictUpdateInfo /* printProc */ + PrintDictUpdateInfo, /* printProc */ + DisassembleDictUpdateInfo /* disassembleProc */ }; /* @@ -289,7 +301,8 @@ TclCompileArraySetCmd( * a proc, we cannot do a better compile than generic. */ - if (envPtr->procPtr == NULL && !(isDataEven && len == 0)) { + if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || + (envPtr->procPtr == NULL && !(isDataEven && len == 0))) { code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); goto done; } @@ -330,8 +343,9 @@ TclCompileArraySetCmd( * a non-local variable: upvar from a local one! This consumes the * variable name that was left at stacktop. */ - - localIndex = AnonymousLocal(envPtr); + + localIndex = TclFindCompiledLocal(varTokenPtr->start, + varTokenPtr->size, 1, envPtr); PushStringLiteral(envPtr, "0"); TclEmitInstInt4(INST_REVERSE, 2, envPtr); TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); @@ -2084,11 +2098,13 @@ TclCompileDictWithCmd( * DupDictUpdateInfo: a copy of the auxiliary data * FreeDictUpdateInfo: none * PrintDictUpdateInfo: none + * DisassembleDictUpdateInfo: none * * Side effects: * DupDictUpdateInfo: allocates memory * FreeDictUpdateInfo: releases memory * PrintDictUpdateInfo: none + * DisassembleDictUpdateInfo: none * *---------------------------------------------------------------------- */ @@ -2131,6 +2147,25 @@ PrintDictUpdateInfo( Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); } } + +static void +DisassembleDictUpdateInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + DictUpdateInfo *duiPtr = clientData; + int i; + Tcl_Obj *variables = Tcl_NewObj(); + + for (i=0 ; i<duiPtr->length ; i++) { + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewIntObj(duiPtr->varIndices[i])); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1), + variables); +} /* *---------------------------------------------------------------------- @@ -2368,7 +2403,6 @@ TclCompileForCmd( SetLineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - TclClearNumConversion(envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { @@ -2809,10 +2843,10 @@ FreeForeachInfo( /* *---------------------------------------------------------------------- * - * PrintForeachInfo -- + * PrintForeachInfo, DisassembleForeachInfo -- * - * Function to write a human-readable representation of a ForeachInfo - * structure to stdout for debugging. + * Functions to write a human-readable or script-readablerepresentation + * of a ForeachInfo structure to a Tcl_Obj for debugging. * * Results: * None. @@ -2892,6 +2926,89 @@ PrintNewForeachInfo( Tcl_AppendToObj(appendObj, "]", -1); } } + +static void +DisassembleForeachInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + Tcl_Obj *objPtr, *innerPtr; + + /* + * Data stores. + */ + + objPtr = Tcl_NewObj(); + for (i=0 ; i<infoPtr->numLists ; i++) { + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(infoPtr->firstValueTemp + i)); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr); + + /* + * Loop counter. + */ + + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1), + Tcl_NewIntObj(infoPtr->loopCtTemp)); + + /* + * Assignment targets. + */ + + objPtr = Tcl_NewObj(); + for (i=0 ; i<infoPtr->numLists ; i++) { + innerPtr = Tcl_NewObj(); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; j<varsPtr->numVars ; j++) { + Tcl_ListObjAppendElement(NULL, innerPtr, + Tcl_NewIntObj(varsPtr->varIndexes[j])); + } + Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); +} + +static void +DisassembleNewForeachInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + Tcl_Obj *objPtr, *innerPtr; + + /* + * Jump offset. + */ + + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1), + Tcl_NewIntObj(infoPtr->loopCtTemp)); + + /* + * Assignment targets. + */ + + objPtr = Tcl_NewObj(); + for (i=0 ; i<infoPtr->numLists ; i++) { + innerPtr = Tcl_NewObj(); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; j<varsPtr->numVars ; j++) { + Tcl_ListObjAppendElement(NULL, innerPtr, + Tcl_NewIntObj(varsPtr->varIndexes[j])); + } + Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 166fea0..98407f7 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -281,7 +281,6 @@ TclCompileIfCmd( SetLineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - TclClearNumConversion(envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } @@ -531,7 +530,6 @@ TclCompileIncrCmd( } else { SetLineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); - TclClearNumConversion(envPtr); } } else { /* No incr amount given so use 1. */ haveImmValue = 1; @@ -873,7 +871,7 @@ TclCompileLappendCmd( /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; - if (numWords == 1) { + if (numWords < 3) { return TCL_ERROR; } @@ -1480,7 +1478,7 @@ TclCompileLreplaceCmd( Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ Tcl_Obj *tmpObj; - int idx1, idx2, i, offset; + int idx1, idx2, i, offset, offset2; if (parsePtr->numWords < 4) { return TCL_ERROR; @@ -1586,12 +1584,18 @@ TclCompileLreplaceCmd( TclEmitOpcode( INST_GT, envPtr); offset = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + offset2 = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( "list doesn't contain element %d", idx1), NULL), envPtr); CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, + envPtr->codeStart + offset2 + 1); TclAdjustStackDepth(-1, envPtr); } TclEmitOpcode( INST_DUP, envPtr); @@ -1636,12 +1640,18 @@ TclCompileLreplaceCmd( TclEmitOpcode( INST_GT, envPtr); offset = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + offset2 = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); 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); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, + envPtr->codeStart + offset2 + 1); TclAdjustStackDepth(-1, envPtr); } TclEmitOpcode( INST_DUP, envPtr); @@ -2258,7 +2268,7 @@ TclCompileRegexpCmd( * converted pattern as a literal. */ - if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) + if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL) == TCL_OK) { simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); @@ -2350,7 +2360,7 @@ TclCompileRegsubCmd( Tcl_Obj *patternObj = NULL, *replacementObj = NULL; Tcl_DString pattern; const char *bytes; - int len, exact, result = TCL_ERROR; + int len, exact, quantified, result = TCL_ERROR; if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { return TCL_ERROR; @@ -2410,7 +2420,8 @@ TclCompileRegsubCmd( */ bytes = Tcl_GetStringFromObj(patternObj, &len); - if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { + if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) + != TCL_OK || exact || quantified) { goto done; } bytes = Tcl_DStringValue(&pattern); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index f2e5dd2..382d2d1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -28,6 +28,9 @@ static void FreeJumptableInfo(ClientData clientData); static void PrintJumptableInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleJumptableInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); @@ -72,7 +75,8 @@ const AuxDataType tclJumptableInfoType = { "JumptableInfo", /* name */ DupJumptableInfo, /* dupProc */ FreeJumptableInfo, /* freeProc */ - PrintJumptableInfo /* printProc */ + PrintJumptableInfo, /* printProc */ + DisassembleJumptableInfo /* disassembleProc */ }; /* @@ -318,8 +322,8 @@ TclCompileStringCatCmd( CompileWord(envPtr, wordTokenPtr, interp, i); numArgs ++; if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */ - TclEmitInstInt1(INST_STR_CONCAT1, 254, envPtr); - numArgs -= 253; /* concat pushes 1 obj, the result */ + TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); + numArgs = 1; /* concat pushes 1 obj, the result */ } } wordTokenPtr = TokenAfter(wordTokenPtr); @@ -2091,7 +2095,7 @@ IssueSwitchChainedTests( */ if (TclReToGlob(NULL, bodyToken[i]->start, - bodyToken[i]->size, &ds, &exact) == TCL_OK) { + bodyToken[i]->size, &ds, &exact, NULL) == TCL_OK){ simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); @@ -2441,11 +2445,13 @@ IssueSwitchJumpTable( * DupJumptableInfo: a copy of the jump-table * FreeJumptableInfo: none * PrintJumptableInfo: none + * DisassembleJumptableInfo: none * * Side effects: * DupJumptableInfo: allocates memory * FreeJumptableInfo: releases memory * PrintJumptableInfo: none + * DisassembleJumptableInfo: none * *---------------------------------------------------------------------- */ @@ -2508,6 +2514,30 @@ PrintJumptableInfo( keyPtr, pcOffset + offset); } } + +static void +DisassembleJumptableInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register JumptableInfo *jtPtr = clientData; + Tcl_Obj *mapping = Tcl_NewObj(); + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + const char *keyPtr; + int offset; + + hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { + keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr); + offset = PTR2INT(Tcl_GetHashValue(hPtr)); + Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1), + Tcl_NewIntObj(offset)); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping); +} /* *---------------------------------------------------------------------- @@ -3038,6 +3068,7 @@ IssueTryClausesInstructions( if (!handlerTokens[i]) { forwardsNeedFixing = 1; JUMP4( JUMP, forwardsToFix[i]); + TclAdjustStackDepth(1, envPtr); } else { int dontChangeOptions; @@ -3751,7 +3782,6 @@ TclCompileWhileCmd( } SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - TclClearNumConversion(envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 838b195..3736498 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -55,9 +55,9 @@ InstructionDesc const tclInstructionTable[] = { /* Name Bytes stackEffect #Opnds Operand types */ {"done", 1, -1, 0, {OPERAND_NONE}}, /* Finish ByteCode execution and return stktop (top stack item) */ - {"push1", 2, +1, 1, {OPERAND_UINT1}}, + {"push1", 2, +1, 1, {OPERAND_LIT1}}, /* Push object at ByteCode objArray[op1] */ - {"push4", 5, +1, 1, {OPERAND_UINT4}}, + {"push4", 5, +1, 1, {OPERAND_LIT4}}, /* Push object at ByteCode objArray[op4] */ {"pop", 1, -1, 0, {OPERAND_NONE}}, /* Pop the topmost stack object */ @@ -125,17 +125,17 @@ InstructionDesc const tclInstructionTable[] = { {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr general variable; unparsed name is top, amount is op1 */ - {"jump1", 2, 0, 1, {OPERAND_INT1}}, + {"jump1", 2, 0, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) */ - {"jump4", 5, 0, 1, {OPERAND_INT4}}, + {"jump4", 5, 0, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpTrue1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ {"lor", 1, -1, 0, {OPERAND_NONE}}, @@ -298,7 +298,7 @@ InstructionDesc const tclInstructionTable[] = { /* List Index: push (lindex stktop op4) */ {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* List Range: push (lrange stktop op4 op4) */ - {"startCommand", 9, 0, 2, {OPERAND_INT4,OPERAND_UINT4}}, + {"startCommand", 9, 0, 2, {OPERAND_OFFSET4, OPERAND_UINT4}}, /* Start of bytecoded command: op is the length of the cmd's code, op2 * is number of commands here */ @@ -692,11 +692,6 @@ static void RegisterAuxDataType(const AuxDataType *typePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void StartExpanding(CompileEnv *envPtr); -static int FormatInstruction(ByteCode *codePtr, - const unsigned char *pc, Tcl_Obj *bufferObj); -static void PrintSourceToObj(Tcl_Obj *appendObj, - const char *stringPtr, int maxChars); -static void UpdateStringOfInstName(Tcl_Obj *objPtr); /* * TIP #280: Helper for building the per-word line information of all compiled @@ -735,19 +730,6 @@ static const Tcl_ObjType substCodeType = { }; /* - * The structure below defines an instruction name Tcl object to allow - * reporting of inner contexts in errorstack without string allocation. - */ - -static const Tcl_ObjType tclInstNameType = { - "instname", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfInstName, /* updateStringProc */ - NULL, /* setFromAnyProc */ -}; - -/* * Helper macros. */ @@ -4596,796 +4578,6 @@ EncodeCmdLocMap( return p; } -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * TclPrintByteCodeObj -- - * - * This procedure prints ("disassembles") the instructions of a bytecode - * object to stdout. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintByteCodeObj( - Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); - - fprintf(stdout, "\n%s", TclGetString(bufPtr)); - Tcl_DecrRefCount(bufPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintInstruction -- - * - * This procedure prints ("disassembles") one instruction from a bytecode - * object to stdout. - * - * Results: - * Returns the length in bytes of the current instruiction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclPrintInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc) /* Points to first byte of instruction. */ -{ - Tcl_Obj *bufferObj; - int numBytes; - - TclNewObj(bufferObj); - numBytes = FormatInstruction(codePtr, pc, bufferObj); - fprintf(stdout, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintObject -- - * - * This procedure prints up to a specified number of characters from the - * argument Tcl object's string representation to a specified file. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintObject( - FILE *outFile, /* The file to print the source to. */ - Tcl_Obj *objPtr, /* Points to the Tcl object whose string - * representation should be printed. */ - int maxChars) /* Maximum number of chars to print. */ -{ - char *bytes; - int length; - - bytes = Tcl_GetStringFromObj(objPtr, &length); - TclPrintSource(outFile, bytes, TclMin(length, maxChars)); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintSource -- - * - * This procedure prints up to a specified number of characters from the - * argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintSource( - FILE *outFile, /* The file to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - Tcl_Obj *bufferObj; - - TclNewObj(bufferObj); - PrintSourceToObj(bufferObj, stringPtr, maxChars); - fprintf(outFile, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * TclDisassembleByteCodeObj -- - * - * Given an object which is of bytecode type, return a disassembled - * version of the bytecode (in a new refcount 0 object). No guarantees - * are made about the details of the contents of the result. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclDisassembleByteCodeObj( - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - unsigned char *codeStart, *codeLimit, *pc; - unsigned char *codeDeltaNext, *codeLengthNext; - unsigned char *srcDeltaNext, *srcLengthNext; - int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; - Interp *iPtr = (Interp *) *codePtr->interpHandle; - Tcl_Obj *bufferObj; - char ptrBuf1[20], ptrBuf2[20]; - - TclNewObj(bufferObj); - if (codePtr->refCount <= 0) { - return bufferObj; /* Already freed. */ - } - - codeStart = codePtr->codeStart; - codeLimit = codeStart + codePtr->numCodeBytes; - numCmds = codePtr->numCommands; - - /* - * Print header lines describing the ByteCode. - */ - - sprintf(ptrBuf1, "%p", codePtr); - sprintf(ptrBuf2, "%p", iPtr); - Tcl_AppendPrintfToObj(bufferObj, - "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", - ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, - iPtr->compileEpoch); - Tcl_AppendToObj(bufferObj, " Source ", -1); - PrintSourceToObj(bufferObj, codePtr->source, - TclMin(codePtr->numSrcBytes, 55)); - Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, - codePtr->numLitObjects, codePtr->numAuxDataItems, - codePtr->maxStackDepth, -#ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - codePtr->structureSize/(float)codePtr->numSrcBytes : -#endif - 0.0); - -#ifdef TCL_COMPILE_STATS - Tcl_AppendPrintfToObj(bufferObj, - " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), - codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), - codePtr->numCmdLocBytes); -#endif /* TCL_COMPILE_STATS */ - - /* - * If the ByteCode is the compiled body of a Tcl procedure, print - * information about that procedure. Note that we don't know the - * procedure's name since ByteCode's can be shared among procedures. - */ - - if (codePtr->procPtr != NULL) { - Proc *procPtr = codePtr->procPtr; - int numCompiledLocals = procPtr->numCompiledLocals; - - sprintf(ptrBuf1, "%p", procPtr); - Tcl_AppendPrintfToObj(bufferObj, - " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", - ptrBuf1, procPtr->refCount, procPtr->numArgs, - numCompiledLocals); - if (numCompiledLocals > 0) { - CompiledLocal *localPtr = procPtr->firstLocalPtr; - - for (i = 0; i < numCompiledLocals; i++) { - Tcl_AppendPrintfToObj(bufferObj, - " slot %d%s%s%s%s%s%s", i, - (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", - (localPtr->flags & VAR_ARRAY) ? ", array" : "", - (localPtr->flags & VAR_LINK) ? ", link" : "", - (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", - (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", - (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); - if (TclIsVarTemporary(localPtr)) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } else { - Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", - localPtr->name); - } - localPtr = localPtr->nextPtr; - } - } - } - - /* - * Print the ExceptionRange array. - */ - - if (codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", - codePtr->numExceptRanges, codePtr->maxExceptDepth); - for (i = 0; i < codePtr->numExceptRanges; i++) { - ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; - - Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %d-%d, ", - i, rangePtr->nestingLevel, - (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), - rangePtr->codeOffset, - (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); - break; - case CATCH_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", - rangePtr->catchOffset); - break; - default: - Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", - rangePtr->type); - } - } - } - - /* - * If there were no commands (e.g., an expression or an empty string was - * compiled), just print all instructions and return. - */ - - if (numCmds == 0) { - pc = codeStart; - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - return bufferObj; - } - - /* - * Print table showing the code offset, source offset, and source length - * for each command. These are encoded as a sequence of bytes. - */ - - Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); - codeDeltaNext = codePtr->codeDeltaStart; - codeLengthNext = codePtr->codeLengthStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { - codeLengthNext++; - codeLen = TclGetInt4AtPtr(codeLengthNext); - codeLengthNext += 4; - } else { - codeLen = TclGetInt1AtPtr(codeLengthNext); - codeLengthNext++; - } - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", - ((i % 2)? " " : "\n "), - (i+1), codeOffset, (codeOffset + codeLen - 1), - srcOffset, (srcOffset + srcLen - 1)); - } - if (numCmds > 0) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } - - /* - * Print each instruction. If the instruction corresponds to the start of - * a command, print the command's source. Note that we don't need the code - * length here. - */ - - codeDeltaNext = codePtr->codeDeltaStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - pc = codeStart; - for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - /* - * Print instructions before command i. - */ - - while ((pc-codeStart) < codeOffset) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - - Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); - PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), - TclMin(srcLen, 55)); - Tcl_AppendToObj(bufferObj, "\n", -1); - } - if (pc < codeLimit) { - /* - * Print instructions after the last command. - */ - - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - } - return bufferObj; -} - -/* - *---------------------------------------------------------------------- - * - * FormatInstruction -- - * - * Appends a representation of a bytecode instruction to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static int -FormatInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc, /* Points to first byte of instruction. */ - Tcl_Obj *bufferObj) /* Object to append instruction info to. */ -{ - Proc *procPtr = codePtr->procPtr; - unsigned char opCode = *pc; - register const InstructionDesc *instDesc = &tclInstructionTable[opCode]; - unsigned char *codeStart = codePtr->codeStart; - unsigned pcOffset = pc - codeStart; - int opnd = 0, i, j, numBytes = 1; - int localCt = procPtr ? procPtr->numCompiledLocals : 0; - CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; - char suffixBuffer[128]; /* Additional info to print after main opcode - * and immediates. */ - char *suffixSrc = NULL; - Tcl_Obj *suffixObj = NULL; - AuxData *auxPtr = NULL; - - suffixBuffer[0] = '\0'; - Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); - for (i = 0; i < instDesc->numOperands; i++) { - switch (instDesc->opTypes[i]) { - case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 - || opCode == INST_JUMP_FALSE1) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - break; - case OPERAND_INT4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 - || opCode == INST_JUMP_FALSE4) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } else if (opCode == INST_START_CMD) { - sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - break; - case OPERAND_UINT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_PUSH1) { - suffixObj = codePtr->objArrayPtr[opnd]; - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - break; - case OPERAND_AUX4: - case OPERAND_UINT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_PUSH4) { - suffixObj = codePtr->objArrayPtr[opnd]; - } else if (opCode == INST_START_CMD && opnd != 1) { - sprintf(suffixBuffer+strlen(suffixBuffer), - ", %u cmds start here", opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - if (instDesc->opTypes[i] == OPERAND_AUX4) { - auxPtr = &codePtr->auxDataArrayPtr[opnd]; - } - break; - case OPERAND_IDX4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opnd >= -1) { - Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); - } else if (opnd == -2) { - Tcl_AppendPrintfToObj(bufferObj, "end "); - } else { - Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); - } - break; - case OPERAND_LVT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); - numBytes++; - goto printLVTindex; - case OPERAND_LVT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); - numBytes += 4; - printLVTindex: - if (localPtr != NULL) { - if (opnd >= localCt) { - Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", - (unsigned) opnd, localCt); - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); - } else { - sprintf(suffixBuffer, "var "); - suffixSrc = localPtr->name; - } - } - Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); - break; - case OPERAND_SCLS1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - Tcl_AppendPrintfToObj(bufferObj, "%s ", - tclStringClassTable[opnd].name); - break; - case OPERAND_NONE: - default: - break; - } - } - if (suffixObj) { - const char *bytes; - int length; - - Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); - PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); - } else if (suffixBuffer[0]) { - Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); - if (suffixSrc) { - PrintSourceToObj(bufferObj, suffixSrc, 40); - } - } - Tcl_AppendToObj(bufferObj, "\n", -1); - if (auxPtr && auxPtr->type->printProc) { - Tcl_AppendToObj(bufferObj, "\t\t[", -1); - auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, - pcOffset); - Tcl_AppendToObj(bufferObj, "]\n", -1); - } - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetInnerContext -- - * - * If possible, returns a list capturing the inner context. Otherwise - * return NULL. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclGetInnerContext( - Tcl_Interp *interp, - const unsigned char *pc, - Tcl_Obj **tosPtr) -{ - int objc = 0, off = 0; - Tcl_Obj *result; - Interp *iPtr = (Interp *) interp; - - switch (*pc) { - case INST_STR_LEN: - case INST_LNOT: - case INST_BITNOT: - case INST_UMINUS: - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: - case INST_EXPAND_STKTOP: - case INST_EXPR_STK: - objc = 1; - break; - - case INST_LIST_IN: - case INST_LIST_NOT_IN: /* Basic list containment operators. */ - case INST_STR_EQ: - case INST_STR_NEQ: /* String (in)equality check */ - case INST_STR_CMP: /* String compare. */ - case INST_STR_INDEX: - case INST_STR_MATCH: - case INST_REGEXP: - case INST_EQ: - case INST_NEQ: - case INST_LT: - case INST_GT: - case INST_LE: - case INST_GE: - case INST_MOD: - case INST_LSHIFT: - case INST_RSHIFT: - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - case INST_EXPON: - case INST_ADD: - case INST_SUB: - case INST_DIV: - case INST_MULT: - objc = 2; - break; - - case INST_RETURN_STK: - /* early pop. TODO: dig out opt dict too :/ */ - objc = 1; - break; - - case INST_SYNTAX: - case INST_RETURN_IMM: - objc = 2; - break; - - case INST_INVOKE_STK4: - objc = TclGetUInt4AtPtr(pc+1); - break; - - case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); - break; - } - - result = iPtr->innerContext; - if (Tcl_IsShared(result)) { - Tcl_DecrRefCount(result); - iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); - Tcl_IncrRefCount(result); - } else { - int len; - - /* - * Reset while keeping the list intrep as much as possible. - */ - - Tcl_ListObjLength(interp, result, &len); - Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); - } - Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); - - for (; objc>0 ; objc--) { - Tcl_Obj *objPtr; - - objPtr = tosPtr[1 - objc + off]; - if (!objPtr) { - Tcl_Panic("InnerContext: bad tos -- appending null object"); - } - if ((objPtr->refCount<=0) -#ifdef TCL_MEM_DEBUG - || (objPtr->refCount==0x61616161) -#endif - ) { - Tcl_Panic("InnerContext: bad tos -- appending freed object %p", - objPtr); - } - Tcl_ListObjAppendElement(NULL, result, objPtr); - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclNewInstNameObj -- - * - * Creates a new InstName Tcl_Obj based on the given instruction - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclNewInstNameObj( - unsigned char inst) -{ - Tcl_Obj *objPtr = Tcl_NewObj(); - - objPtr->typePtr = &tclInstNameType; - objPtr->internalRep.longValue = (long) inst; - objPtr->bytes = NULL; - - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfInstName -- - * - * Update the string representation for an instruction name object. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfInstName( - Tcl_Obj *objPtr) -{ - int inst = objPtr->internalRep.longValue; - char *s, buf[20]; - int len; - - if ((inst < 0) || (inst > LAST_INST_OPCODE)) { - sprintf(buf, "inst_%d", inst); - s = buf; - } else { - s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; - } - len = strlen(s); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, s, len + 1); - objPtr->length = len; -} - -/* - *---------------------------------------------------------------------- - * - * PrintSourceToObj -- - * - * Appends a quoted representation of a string to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static void -PrintSourceToObj( - Tcl_Obj *appendObj, /* The object to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - register const char *p; - register int i = 0, len; - - if (stringPtr == NULL) { - Tcl_AppendToObj(appendObj, "\"\"", -1); - return; - } - - Tcl_AppendToObj(appendObj, "\"", -1); - p = stringPtr; - for (; (*p != '\0') && (i < maxChars); p+=len) { - Tcl_UniChar ch; - - len = TclUtfToUniChar(p, &ch); - switch (ch) { - case '"': - Tcl_AppendToObj(appendObj, "\\\"", -1); - i += 2; - continue; - case '\f': - Tcl_AppendToObj(appendObj, "\\f", -1); - i += 2; - continue; - case '\n': - Tcl_AppendToObj(appendObj, "\\n", -1); - i += 2; - continue; - case '\r': - Tcl_AppendToObj(appendObj, "\\r", -1); - i += 2; - continue; - case '\t': - Tcl_AppendToObj(appendObj, "\\t", -1); - i += 2; - continue; - case '\v': - Tcl_AppendToObj(appendObj, "\\v", -1); - i += 2; - continue; - default: - if (ch < 0x20 || ch >= 0x7f) { - Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch); - i += 6; - } else { - Tcl_AppendPrintfToObj(appendObj, "%c", ch); - i++; - } - continue; - } - } - Tcl_AppendToObj(appendObj, "\"", -1); - if (*p != '\0') { - Tcl_AppendToObj(appendObj, "...", -1); - } -} - #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index fa4a360..51f0b34 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -48,6 +48,13 @@ MODULE_SCOPE int tclTraceCompile; MODULE_SCOPE int tclTraceExec; #endif + +/* + * The type of lambda expressions. Note that every lambda will *always* have a + * string representation. + */ + +MODULE_SCOPE const Tcl_ObjType tclLambdaType; /* *------------------------------------------------------------------------ @@ -238,6 +245,16 @@ typedef struct AuxDataType { AuxDataPrintProc *printProc;/* Callback function to invoke when printing * the aux data as part of debugging. NULL * means that the data can't be printed. */ + AuxDataPrintProc *disassembleProc; + /* Callback function to invoke when doing a + * disassembly of the aux data (like the + * printProc, except that the output is + * intended to be script-readable). The + * appendObj argument should be filled in with + * a descriptive dictionary; it will start out + * with "name" mapped to the content of the + * name field. NULL means that the printProc + * should be used instead. */ } AuxDataType; /* @@ -832,6 +849,12 @@ typedef enum InstOperandType { * variable table. */ OPERAND_AUX4, /* Four byte unsigned index into the aux data * table. */ + OPERAND_OFFSET1, /* One byte signed jump offset. */ + OPERAND_OFFSET4, /* Four byte signed jump offset. */ + OPERAND_LIT1, /* One byte unsigned index into table of + * literals. */ + OPERAND_LIT4, /* Four byte unsigned index into table of + * literals. */ OPERAND_SCLS1 /* Index into tclStringClassTable. */ } InstOperandType; @@ -1165,12 +1188,15 @@ MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, - const char *script, - const char *command, int length, - const unsigned char *pc, Tcl_Obj **tosPtr); + const char *script, const char *command, + int length, const unsigned char *pc, + Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, - const unsigned char *pc, Tcl_Obj **tosPtr); + const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); +MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, + register Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int isLambda); /* @@ -1388,18 +1414,6 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); } while (0) /* - * If the expr compiler finished with TRY_CONVERT, macro to remove it when the - * job is done by the following instruction. - */ - -#define TclClearNumConversion(envPtr) \ - do { \ - if (*(envPtr->codeNext - 1) == INST_TRY_CVT_TO_NUMERIC) { \ - envPtr->codeNext--; \ - } \ - } while (0) - -/* * Macros to update a (signed or unsigned) integer starting at a pointer. The * two variants depend on the number of bytes. The ANSI C "prototypes" for * these macros are: diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c new file mode 100644 index 0000000..b3753c31 --- /dev/null +++ b/generic/tclDisassemble.c @@ -0,0 +1,1403 @@ +/* + * tclDisassemble.c -- + * + * This file contains procedures that disassemble bytecode into either + * human-readable or Tcl-processable forms. + * + * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2013 Donal K. Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include "tclOOInt.h" +#include <assert.h> + +/* + * Prototypes for procedures defined later in this file: + */ + +static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr); +static int FormatInstruction(ByteCode *codePtr, + const unsigned char *pc, Tcl_Obj *bufferObj); +static void PrintSourceToObj(Tcl_Obj *appendObj, + const char *stringPtr, int maxChars); +static void UpdateStringOfInstName(Tcl_Obj *objPtr); + +/* + * The structure below defines an instruction name Tcl object to allow + * reporting of inner contexts in errorstack without string allocation. + */ + +static const Tcl_ObjType tclInstNameType = { + "instname", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInstName, /* updateStringProc */ + NULL, /* setFromAnyProc */ +}; + +/* + * How to get the bytecode out of a Tcl_Obj. + */ + +#define BYTECODE(objPtr) \ + ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1) + +#ifdef TCL_COMPILE_DEBUG +/* + *---------------------------------------------------------------------- + * + * TclPrintByteCodeObj -- + * + * This procedure prints ("disassembles") the instructions of a bytecode + * object to stdout. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintByteCodeObj( + Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); + + fprintf(stdout, "\n%s", TclGetString(bufPtr)); + Tcl_DecrRefCount(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a bytecode + * object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclPrintInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + const unsigned char *pc) /* Points to first byte of instruction. */ +{ + Tcl_Obj *bufferObj; + int numBytes; + + TclNewObj(bufferObj); + numBytes = FormatInstruction(codePtr, pc, bufferObj); + fprintf(stdout, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintObject -- + * + * This procedure prints up to a specified number of characters from the + * argument Tcl object's string representation to a specified file. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintObject( + FILE *outFile, /* The file to print the source to. */ + Tcl_Obj *objPtr, /* Points to the Tcl object whose string + * representation should be printed. */ + int maxChars) /* Maximum number of chars to print. */ +{ + char *bytes; + int length; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from the + * argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintSource( + FILE *outFile, /* The file to print the source to. */ + const char *stringPtr, /* The string to print. */ + int maxChars) /* Maximum number of chars to print. */ +{ + Tcl_Obj *bufferObj; + + TclNewObj(bufferObj); + PrintSourceToObj(bufferObj, stringPtr, maxChars); + fprintf(outFile, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclDisassembleByteCodeObj -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object). No guarantees + * are made about the details of the contents of the result. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDisassembleByteCodeObj( + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + ByteCode *codePtr = BYTECODE(objPtr); + unsigned char *codeStart, *codeLimit, *pc; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; + Interp *iPtr = (Interp *) *codePtr->interpHandle; + Tcl_Obj *bufferObj; + char ptrBuf1[20], ptrBuf2[20]; + + TclNewObj(bufferObj); + if (codePtr->refCount <= 0) { + return bufferObj; /* Already freed. */ + } + + codeStart = codePtr->codeStart; + codeLimit = codeStart + codePtr->numCodeBytes; + numCmds = codePtr->numCommands; + + /* + * Print header lines describing the ByteCode. + */ + + sprintf(ptrBuf1, "%p", codePtr); + sprintf(ptrBuf2, "%p", iPtr); + Tcl_AppendPrintfToObj(bufferObj, + "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", + ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, + iPtr->compileEpoch); + Tcl_AppendToObj(bufferObj, " Source ", -1); + PrintSourceToObj(bufferObj, codePtr->source, + TclMin(codePtr->numSrcBytes, 55)); + Tcl_AppendPrintfToObj(bufferObj, + "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, + codePtr->numLitObjects, codePtr->numAuxDataItems, + codePtr->maxStackDepth, +#ifdef TCL_COMPILE_STATS + codePtr->numSrcBytes? + codePtr->structureSize/(float)codePtr->numSrcBytes : +#endif + 0.0); + +#ifdef TCL_COMPILE_STATS + Tcl_AppendPrintfToObj(bufferObj, + " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + (unsigned long) codePtr->structureSize, + (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), + codePtr->numCodeBytes, + (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), + (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); +#endif /* TCL_COMPILE_STATS */ + + /* + * If the ByteCode is the compiled body of a Tcl procedure, print + * information about that procedure. Note that we don't know the + * procedure's name since ByteCode's can be shared among procedures. + */ + + if (codePtr->procPtr != NULL) { + Proc *procPtr = codePtr->procPtr; + int numCompiledLocals = procPtr->numCompiledLocals; + + sprintf(ptrBuf1, "%p", procPtr); + Tcl_AppendPrintfToObj(bufferObj, + " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", + ptrBuf1, procPtr->refCount, procPtr->numArgs, + numCompiledLocals); + if (numCompiledLocals > 0) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + + for (i = 0; i < numCompiledLocals; i++) { + Tcl_AppendPrintfToObj(bufferObj, + " slot %d%s%s%s%s%s%s", i, + (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", + (localPtr->flags & VAR_ARRAY) ? ", array" : "", + (localPtr->flags & VAR_LINK) ? ", link" : "", + (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", + (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", + (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); + if (TclIsVarTemporary(localPtr)) { + Tcl_AppendToObj(bufferObj, "\n", -1); + } else { + Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", + localPtr->name); + } + localPtr = localPtr->nextPtr; + } + } + } + + /* + * Print the ExceptionRange array. + */ + + if (codePtr->numExceptRanges > 0) { + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", + codePtr->numExceptRanges, codePtr->maxExceptDepth); + for (i = 0; i < codePtr->numExceptRanges; i++) { + ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; + + Tcl_AppendPrintfToObj(bufferObj, + " %d: level %d, %s, pc %d-%d, ", + i, rangePtr->nestingLevel, + (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); + break; + case CATCH_EXCEPTION_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", + rangePtr->catchOffset); + break; + default: + Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", + rangePtr->type); + } + } + } + + /* + * If there were no commands (e.g., an expression or an empty string was + * compiled), just print all instructions and return. + */ + + if (numCmds == 0) { + pc = codeStart; + while (pc < codeLimit) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + return bufferObj; + } + + /* + * Print table showing the code offset, source offset, and source length + * for each command. These are encoded as a sequence of bytes. + */ + + Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", + ((i % 2)? " " : "\n "), + (i+1), codeOffset, (codeOffset + codeLen - 1), + srcOffset, (srcOffset + srcLen - 1)); + } + if (numCmds > 0) { + Tcl_AppendToObj(bufferObj, "\n", -1); + } + + /* + * Print each instruction. If the instruction corresponds to the start of + * a command, print the command's source. Note that we don't need the code + * length here. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + pc = codeStart; + for (i = 0; i < numCmds; i++) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + /* + * Print instructions before command i. + */ + + while ((pc-codeStart) < codeOffset) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + + Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); + PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), + TclMin(srcLen, 55)); + Tcl_AppendToObj(bufferObj, "\n", -1); + } + if (pc < codeLimit) { + /* + * Print instructions after the last command. + */ + + while (pc < codeLimit) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + } + return bufferObj; +} + +/* + *---------------------------------------------------------------------- + * + * FormatInstruction -- + * + * Appends a representation of a bytecode instruction to a Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +static int +FormatInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + const unsigned char *pc, /* Points to first byte of instruction. */ + Tcl_Obj *bufferObj) /* Object to append instruction info to. */ +{ + Proc *procPtr = codePtr->procPtr; + unsigned char opCode = *pc; + register const InstructionDesc *instDesc = &tclInstructionTable[opCode]; + unsigned char *codeStart = codePtr->codeStart; + unsigned pcOffset = pc - codeStart; + int opnd = 0, i, j, numBytes = 1; + int localCt = procPtr ? procPtr->numCompiledLocals : 0; + CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; + char suffixBuffer[128]; /* Additional info to print after main opcode + * and immediates. */ + char *suffixSrc = NULL; + Tcl_Obj *suffixObj = NULL; + AuxData *auxPtr = NULL; + + suffixBuffer[0] = '\0'; + Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); + for (i = 0; i < instDesc->numOperands; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_INT4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_UINT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_UINT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_START_CMD) { + sprintf(suffixBuffer+strlen(suffixBuffer), + ", %u cmds start here", opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_OFFSET1: + opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_OFFSET4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_START_CMD) { + sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); + } else { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_LIT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + suffixObj = codePtr->objArrayPtr[opnd]; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_LIT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + suffixObj = codePtr->objArrayPtr[opnd]; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_AUX4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + auxPtr = &codePtr->auxDataArrayPtr[opnd]; + break; + case OPERAND_IDX4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opnd >= -1) { + Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); + } else if (opnd == -2) { + Tcl_AppendPrintfToObj(bufferObj, "end "); + } else { + Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); + } + break; + case OPERAND_LVT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; + goto printLVTindex; + case OPERAND_LVT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); + numBytes += 4; + printLVTindex: + if (localPtr != NULL) { + if (opnd >= localCt) { + Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", + (unsigned) opnd, localCt); + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); + } else { + sprintf(suffixBuffer, "var "); + suffixSrc = localPtr->name; + } + } + Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); + break; + case OPERAND_SCLS1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + Tcl_AppendPrintfToObj(bufferObj, "%s ", + tclStringClassTable[opnd].name); + break; + case OPERAND_NONE: + default: + break; + } + } + if (suffixObj) { + const char *bytes; + int length; + + Tcl_AppendToObj(bufferObj, "\t# ", -1); + bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); + PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); + } else if (suffixBuffer[0]) { + Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); + if (suffixSrc) { + PrintSourceToObj(bufferObj, suffixSrc, 40); + } + } + Tcl_AppendToObj(bufferObj, "\n", -1); + if (auxPtr && auxPtr->type->printProc) { + Tcl_AppendToObj(bufferObj, "\t\t[", -1); + auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, + pcOffset); + Tcl_AppendToObj(bufferObj, "]\n", -1); + } + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetInnerContext -- + * + * If possible, returns a list capturing the inner context. Otherwise + * return NULL. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetInnerContext( + Tcl_Interp *interp, + const unsigned char *pc, + Tcl_Obj **tosPtr) +{ + int objc = 0, off = 0; + Tcl_Obj *result; + Interp *iPtr = (Interp *) interp; + + switch (*pc) { + case INST_STR_LEN: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + case INST_EXPAND_STKTOP: + case INST_EXPR_STK: + objc = 1; + break; + + case INST_LIST_IN: + case INST_LIST_NOT_IN: /* Basic list containment operators. */ + case INST_STR_EQ: + case INST_STR_NEQ: /* String (in)equality check */ + case INST_STR_CMP: /* String compare. */ + case INST_STR_INDEX: + case INST_STR_MATCH: + case INST_REGEXP: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + objc = 2; + break; + + case INST_RETURN_STK: + /* early pop. TODO: dig out opt dict too :/ */ + objc = 1; + break; + + case INST_SYNTAX: + case INST_RETURN_IMM: + objc = 2; + break; + + case INST_INVOKE_STK4: + objc = TclGetUInt4AtPtr(pc+1); + break; + + case INST_INVOKE_STK1: + objc = TclGetUInt1AtPtr(pc+1); + break; + } + + result = iPtr->innerContext; + if (Tcl_IsShared(result)) { + Tcl_DecrRefCount(result); + iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); + Tcl_IncrRefCount(result); + } else { + int len; + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjLength(interp, result, &len); + Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); + } + Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); + + for (; objc>0 ; objc--) { + Tcl_Obj *objPtr; + + objPtr = tosPtr[1 - objc + off]; + if (!objPtr) { + Tcl_Panic("InnerContext: bad tos -- appending null object"); + } + if ((objPtr->refCount<=0) +#ifdef TCL_MEM_DEBUG + || (objPtr->refCount==0x61616161) +#endif + ) { + Tcl_Panic("InnerContext: bad tos -- appending freed object %p", + objPtr); + } + Tcl_ListObjAppendElement(NULL, result, objPtr); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewInstNameObj -- + * + * Creates a new InstName Tcl_Obj based on the given instruction + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclNewInstNameObj( + unsigned char inst) +{ + Tcl_Obj *objPtr = Tcl_NewObj(); + + objPtr->typePtr = &tclInstNameType; + objPtr->internalRep.longValue = (long) inst; + objPtr->bytes = NULL; + + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfInstName -- + * + * Update the string representation for an instruction name object. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfInstName( + Tcl_Obj *objPtr) +{ + int inst = objPtr->internalRep.longValue; + char *s, buf[20]; + int len; + + if ((inst < 0) || (inst > LAST_INST_OPCODE)) { + sprintf(buf, "inst_%d", inst); + s = buf; + } else { + s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + } + len = strlen(s); + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, s, len + 1); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * PrintSourceToObj -- + * + * Appends a quoted representation of a string to a Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +static void +PrintSourceToObj( + Tcl_Obj *appendObj, /* The object to print the source to. */ + const char *stringPtr, /* The string to print. */ + int maxChars) /* Maximum number of chars to print. */ +{ + register const char *p; + register int i = 0, len; + + if (stringPtr == NULL) { + Tcl_AppendToObj(appendObj, "\"\"", -1); + return; + } + + Tcl_AppendToObj(appendObj, "\"", -1); + p = stringPtr; + for (; (*p != '\0') && (i < maxChars); p+=len) { + Tcl_UniChar ch; + + len = TclUtfToUniChar(p, &ch); + switch (ch) { + case '"': + Tcl_AppendToObj(appendObj, "\\\"", -1); + i += 2; + continue; + case '\f': + Tcl_AppendToObj(appendObj, "\\f", -1); + i += 2; + continue; + case '\n': + Tcl_AppendToObj(appendObj, "\\n", -1); + i += 2; + continue; + case '\r': + Tcl_AppendToObj(appendObj, "\\r", -1); + i += 2; + continue; + case '\t': + Tcl_AppendToObj(appendObj, "\\t", -1); + i += 2; + continue; + case '\v': + Tcl_AppendToObj(appendObj, "\\v", -1); + i += 2; + continue; + default: + if (ch < 0x20 || ch >= 0x7f) { + Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch); + i += 6; + } else { + Tcl_AppendPrintfToObj(appendObj, "%c", ch); + i++; + } + continue; + } + } + Tcl_AppendToObj(appendObj, "\"", -1); + if (*p != '\0') { + Tcl_AppendToObj(appendObj, "...", -1); + } +} + +/* + *---------------------------------------------------------------------- + * + * DisassembleByteCodeAsDicts -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object) in a dictionary. + * No guarantees are made about the details of the contents of the + * result, but it is intended to be more readable than the old output + * format. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +DisassembleByteCodeAsDicts( + Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ +{ + ByteCode *codePtr = BYTECODE(objPtr); + Tcl_Obj *description, *literals, *variables, *instructions, *inst; + Tcl_Obj *aux, *exn, *commands; + unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; + int codeOffset, codeLength, sourceOffset, sourceLength; + int i, val; + + /* + * Get the literals from the bytecode. + */ + + literals = Tcl_NewObj(); + for (i=0 ; i<codePtr->numLitObjects ; i++) { + Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); + } + + /* + * Get the variables from the bytecode. + */ + + variables = Tcl_NewObj(); + if (codePtr->procPtr) { + int localCount = codePtr->procPtr->numCompiledLocals; + CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; + + for (i=0 ; i<localCount ; i++,localPtr=localPtr->nextPtr) { + Tcl_Obj *descriptor[2]; + + descriptor[0] = Tcl_NewObj(); + if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("scalar", -1)); + } + if (localPtr->flags & VAR_ARRAY) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("array", -1)); + } + if (localPtr->flags & VAR_LINK) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("link", -1)); + } + if (localPtr->flags & VAR_ARGUMENT) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("arg", -1)); + } + if (localPtr->flags & VAR_TEMPORARY) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("temp", -1)); + } + if (localPtr->flags & VAR_RESOLVED) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("resolved", -1)); + } + if (localPtr->flags & VAR_TEMPORARY) { + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewListObj(1, descriptor)); + } else { + descriptor[1] = Tcl_NewStringObj(localPtr->name, -1); + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewListObj(2, descriptor)); + } + } + } + + /* + * Get the instructions from the bytecode. + */ + + instructions = Tcl_NewObj(); + for (pc=codePtr->codeStart; pc<codePtr->codeStart+codePtr->numCodeBytes;){ + const InstructionDesc *instDesc = &tclInstructionTable[*pc]; + int address = pc - codePtr->codeStart; + + inst = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( + instDesc->name, -1)); + opnd = pc + 1; + for (i=0 ; i<instDesc->numOperands ; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + val = TclGetInt1AtPtr(opnd); + opnd += 1; + goto formatNumber; + case OPERAND_UINT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + goto formatNumber; + case OPERAND_INT4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + goto formatNumber; + case OPERAND_UINT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + formatNumber: + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + break; + + case OPERAND_OFFSET1: + val = TclGetInt1AtPtr(opnd); + opnd += 1; + goto formatAddress; + case OPERAND_OFFSET4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + formatAddress: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "pc %d", address + val)); + break; + + case OPERAND_LIT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + goto formatLiteral; + case OPERAND_LIT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + formatLiteral: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "@%d", val)); + break; + + case OPERAND_LVT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + goto formatVariable; + case OPERAND_LVT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + formatVariable: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "%%%d", val)); + break; + case OPERAND_IDX4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + if (val >= -1) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + ".%d", val)); + } else if (val == -2) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( + ".end", -1)); + } else { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + ".end-%d", -2-val)); + } + break; + case OPERAND_AUX4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "?%d", val)); + break; + case OPERAND_SCLS1: + val = TclGetUInt1AtPtr(opnd); + opnd++; + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "=%s", tclStringClassTable[val].name)); + break; + case OPERAND_NONE: + Tcl_Panic("opcode %d with more than zero 'no' operands", *pc); + } + } + Tcl_DictObjPut(NULL, instructions, Tcl_NewIntObj(address), inst); + pc += instDesc->numBytes; + } + + /* + * Get the auxiliary data from the bytecode. + */ + + aux = Tcl_NewObj(); + for (i=0 ; i<codePtr->numAuxDataItems ; i++) { + AuxData *auxData = &codePtr->auxDataArrayPtr[i]; + Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); + + if (auxData->type->disassembleProc) { + Tcl_Obj *desc = Tcl_NewObj(); + + Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc); + auxDesc = desc; + auxData->type->disassembleProc(auxData->clientData, auxDesc, + codePtr, 0); + } else if (auxData->type->printProc) { + Tcl_Obj *desc = Tcl_NewObj(); + + auxData->type->printProc(auxData->clientData, desc, codePtr, 0); + Tcl_ListObjAppendElement(NULL, auxDesc, desc); + } + Tcl_ListObjAppendElement(NULL, aux, auxDesc); + } + + /* + * Get the exception ranges from the bytecode. + */ + + exn = Tcl_NewObj(); + for (i=0 ; i<codePtr->numExceptRanges ; i++) { + ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; + + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( + "type %s level %d from %d to %d break %d continue %d", + "loop", rangePtr->nestingLevel, rangePtr->codeOffset, + rangePtr->codeOffset + rangePtr->numCodeBytes - 1, + rangePtr->breakOffset, rangePtr->continueOffset)); + break; + case CATCH_EXCEPTION_RANGE: + Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( + "type %s level %d from %d to %d catch %d", + "catch", rangePtr->nestingLevel, rangePtr->codeOffset, + rangePtr->codeOffset + rangePtr->numCodeBytes - 1, + rangePtr->catchOffset)); + break; + } + } + + /* + * Get the command information from the bytecode. + * + * The way these are encoded in the bytecode is non-trivial; the Decode + * macro (which updates its argument and returns the next decoded value) + * handles this so that the rest of the code does not. + */ + +#define Decode(ptr) \ + ((TclGetUInt1AtPtr(ptr) == 0xFF) \ + ? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4)) \ + : ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1))) + + commands = Tcl_NewObj(); + codeOffPtr = codePtr->codeDeltaStart; + codeLenPtr = codePtr->codeLengthStart; + srcOffPtr = codePtr->srcDeltaStart; + srcLenPtr = codePtr->srcLengthStart; + codeOffset = sourceOffset = 0; + for (i=0 ; i<codePtr->numCommands ; i++) { + Tcl_Obj *cmd; + + codeOffset += Decode(codeOffPtr); + codeLength = Decode(codeLenPtr); + sourceOffset += Decode(srcOffPtr); + sourceLength = Decode(srcLenPtr); + cmd = Tcl_NewObj(); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1), + Tcl_NewIntObj(codeOffset)); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1), + Tcl_NewIntObj(codeOffset + codeLength - 1)); + + /* + * Convert byte offsets to character offsets; important if multibyte + * characters are present in the source! + */ + + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), + Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + sourceOffset))); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1), + Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + sourceOffset + sourceLength - 1))); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1), + Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); + Tcl_ListObjAppendElement(NULL, commands, cmd); + } + +#undef Decode + + /* + * Build the overall result. + */ + + description = Tcl_NewObj(); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1), + literals); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1), + variables); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1), + instructions); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1), + commands); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1), + Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1), + Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1), + Tcl_NewIntObj(codePtr->maxStackDepth)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1), + Tcl_NewIntObj(codePtr->maxExceptDepth)); + return description; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DisassembleObjCmd -- + * + * Implementation of the "::tcl::unsupported::disassemble" command. This + * command is not documented, but will disassemble procedures, lambda + * terms and general scripts. Note that will compile terms if necessary + * in order to disassemble them. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DisassembleObjCmd( + ClientData clientData, /* What type of operation. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const types[] = { + "lambda", "method", "objmethod", "proc", "script", NULL + }; + enum Types { + DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, + DISAS_SCRIPT + }; + int idx, result; + Tcl_Obj *codeObjPtr = NULL; + Proc *procPtr = NULL; + Tcl_HashEntry *hPtr; + Object *oPtr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "type ..."); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ + return TCL_ERROR; + } + + switch ((enum Types) idx) { + case DISAS_LAMBDA: { + Command cmd; + Tcl_Obj *nsObjPtr; + Tcl_Namespace *nsPtr; + + /* + * Compile (if uncompiled) and disassemble a lambda term. + * + * WARNING! Pokes inside the lambda objtype. + */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); + return TCL_ERROR; + } + if (objv[2]->typePtr == &tclLambdaType) { + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { + result = tclLambdaType.setFromAnyProc(interp, objv[2]); + if (result != TCL_OK) { + return result; + } + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + + memset(&cmd, 0, sizeof(Command)); + nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + cmd.nsPtr = (Namespace *) nsPtr; + procPtr->cmdPtr = &cmd; + result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; + } + case DISAS_PROC: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procName"); + return TCL_ERROR; + } + + procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = TclPushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; + case DISAS_SCRIPT: + /* + * Compile and disassemble a script. + */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "script"); + return TCL_ERROR; + } + if ((objv[2]->typePtr != &tclByteCodeType) + && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + return TCL_ERROR; + } + codeObjPtr = objv[2]; + break; + + case DISAS_CLASS_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); + return TCL_ERROR; + } + + /* + * Look up the body of a class method. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, + (char *) objv[3]); + goto methodBody; + case DISAS_OBJECT_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); + return TCL_ERROR; + } + + /* + * Look up the body of an instance method. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->methodsPtr == NULL) { + goto unknownMethod; + } + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); + + /* + * Compile (if necessary) and disassemble a method body. + */ + + methodBody: + if (hPtr == NULL) { + unknownMethod: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[3]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[3]), NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); + return TCL_ERROR; + } + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of method", + TclGetString(objv[3])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + default: + CLANG_ASSERT(0); + } + + /* + * Do the actual disassembly. + */ + + if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not disassemble prebuilt bytecode", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "BYTECODE", NULL); + return TCL_ERROR; + } + if (PTR2INT(clientData)) { + Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(codeObjPtr)); + } else { + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); + } + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 941d566..3985767 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1309,7 +1309,6 @@ Tcl_FinalizeThread(void) * * Fix [Bug #571002] */ - TclFinalizeThreadData(); } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2e03ab4..337a75f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -81,9 +81,7 @@ int tclTraceExec = 0; static const char *const operatorStrings[] = { "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", - "+", "-", "*", "/", "%", "+", "-", "~", "!", - "BUILTIN FUNCTION", "FUNCTION", - "", "", "", "", "", "", "", "", "eq", "ne" + "+", "-", "*", "/", "%", "+", "-", "~", "!" }; /* @@ -9830,7 +9828,7 @@ IllegalExprOperandType( if (opcode == INST_EXPON) { operator = "**"; - } else if (opcode <= INST_STR_NEQ) { + } else if (opcode <= INST_LNOT) { operator = operatorStrings[opcode - INST_LOR]; } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 5d4702b..a7251bb 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -235,9 +235,9 @@ ExtractWinRoot( if ((path[0] == 'c' || path[0] == 'C') && (path[1] == 'o' || path[1] == 'O')) { if ((path[2] == 'm' || path[2] == 'M') - && path[3] >= '1' && path[3] <= '4') { + && path[3] >= '1' && path[3] <= '9') { /* - * May have match for 'com[1-4]:?', which is a serial port. + * May have match for 'com[1-9]:?', which is a serial port. */ if (path[4] == '\0') { @@ -257,9 +257,9 @@ ExtractWinRoot( } else if ((path[0] == 'l' || path[0] == 'L') && (path[1] == 'p' || path[1] == 'P') && (path[2] == 't' || path[2] == 'T')) { - if (path[3] >= '1' && path[3] <= '3') { + if (path[3] >= '1' && path[3] <= '9') { /* - * May have match for 'lpt[1-3]:?' + * May have match for 'lpt[1-9]:?' */ if (path[4] == '\0') { diff --git a/generic/tclIO.c b/generic/tclIO.c index eaa0aeb..2025742 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -35,15 +35,15 @@ typedef struct ChannelHandler { /* * This structure keeps track of the current ChannelHandler being invoked in - * the current invocation of ChannelHandlerEventProc. There is a potential + * the current invocation of Tcl_NotifyChannel. There is a potential * problem if a ChannelHandler is deleted while it is the current one, since - * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * Tcl_NotifyChannel needs to look at the nextPtr field. To handle this * problem, structures of the type below indicate the next handler to be * processed for any (recursively nested) dispatches in progress. The * nextHandlerPtr field is updated if the handler being pointed to is deleted. - * The nextPtr field is used to chain together all recursive invocations, so - * that Tcl_DeleteChannelHandler can find all the recursively nested - * invocations of ChannelHandlerEventProc and compare the handler being + * The nestedHandlerPtr field is used to chain together all recursive + * invocations, so that Tcl_DeleteChannelHandler can find all the recursively + * nested invocations of Tcl_NotifyChannel and compare the handler being * deleted against the NEXT handler to be invoked in that invocation; when it * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr * field of the structure to the next handler. @@ -54,21 +54,10 @@ typedef struct NextChannelHandler { * this invocation. */ struct NextChannelHandler *nestedHandlerPtr; /* Next nested invocation of - * ChannelHandlerEventProc. */ + * Tcl_NotifyChannel. */ } NextChannelHandler; /* - * The following structure describes the event that is added to the Tcl - * event queue by the channel handler check procedure. - */ - -typedef struct ChannelHandlerEvent { - Tcl_Event header; /* Standard header for all events. */ - Channel *chanPtr; /* The channel that is ready. */ - int readyMask; /* Events that have occurred. */ -} ChannelHandlerEvent; - -/* * The following structure is used by Tcl_GetsObj() to encapsulates the * state for a "gets" operation. */ @@ -130,7 +119,7 @@ typedef struct CopyState { typedef struct ThreadSpecificData { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of nested - * ChannelHandlerEventProc invocations. */ + * Tcl_NotifyChannel invocations. */ ChannelState *firstCSPtr; /* List of all channels currently open, * indexed by ChannelState, as only one * ChannelState exists per set of stacked @@ -166,6 +155,7 @@ static ChannelBuffer * AllocChannelBuffer(int length); static void PreserveChannelBuffer(ChannelBuffer *bufPtr); static void ReleaseChannelBuffer(ChannelBuffer *bufPtr); static int IsShared(ChannelBuffer *bufPtr); +static void ChannelFree(Channel *chanPtr); static void ChannelTimerProc(ClientData clientData); static int ChanRead(Channel *chanPtr, char *dst, int dstSize); static int CheckChannelErrors(ChannelState *statePtr, @@ -1925,6 +1915,16 @@ TclChannelRelease( } } +static void +ChannelFree( + Channel *chanPtr) +{ + if (chanPtr->refCount == 0) { + ckfree(chanPtr); + return; + } + chanPtr->typePtr = NULL; +} /* *---------------------------------------------------------------------- @@ -2071,7 +2071,7 @@ Tcl_UnstackChannel( */ result = ChanClose(chanPtr, interp); - chanPtr->typePtr = NULL; + ChannelFree(chanPtr); UpdateInterest(statePtr->topChanPtr); @@ -2822,9 +2822,15 @@ FlushChannel( * write in this call, and we've completed the BG flush. * These are the two cases above. If we get here, that means * there is some kind failure in the writable event machinery. - */ + * + * The tls extension indeed suffers from flaws in its channel + * event mgmt. See http://core.tcl.tk/tcl/info/c31ca233ca. + * Until that patch is broadly distributed, disable the + * assertion checking here, so that programs using Tcl and + * tls can be debugged. assert(!calledFromAsyncFlush); + */ } } @@ -3023,7 +3029,8 @@ CloseChannel( statePtr->topChanPtr = downChanPtr; downChanPtr->upChanPtr = NULL; - chanPtr->typePtr = NULL; + + ChannelFree(chanPtr); return Tcl_Close(interp, (Tcl_Channel) downChanPtr); } @@ -3034,7 +3041,7 @@ CloseChannel( * stack, make sure to free the ChannelState structure associated with it. */ - chanPtr->typePtr = NULL; + ChannelFree(chanPtr); Tcl_EventuallyFree(statePtr, TCL_DYNAMIC); @@ -3905,7 +3912,10 @@ Tcl_Write( if (srcLen < 0) { srcLen = strlen(src); } - return WriteBytes(chanPtr, src, srcLen); + if (WriteBytes(chanPtr, src, srcLen) < 0) { + return -1; + } + return srcLen; } /* @@ -4396,6 +4406,21 @@ Tcl_GetsObj( } /* + * If we're sitting ready to read the eofchar, there's no need to + * do it. + */ + + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + SetFlag(statePtr, CHANNEL_EOF); + assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); + assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + + /* TODO: Do we need this? */ + UpdateInterest(chanPtr); + return -1; + } + + /* * A binary version of Tcl_GetsObj. This could also handle encodings that * are ascii-7 pure (iso8859, utf-8, ...) with a final encoding conversion * done on objPtr. @@ -4461,6 +4486,7 @@ Tcl_GetsObj( eof = NULL; inEofChar = statePtr->inEofChar; + ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { if (dst >= dstEnd) { if (FilterInputBytes(chanPtr, &gs) != 0) { @@ -4612,6 +4638,7 @@ Tcl_GetsObj( dstEnd = eof; SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } if (GotFlag(statePtr, CHANNEL_EOF)) { skip = 0; @@ -4725,6 +4752,13 @@ Tcl_GetsObj( */ done: + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); + /* * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. @@ -4748,6 +4782,11 @@ Tcl_GetsObj( * end-of-line or end-of-file has been seen. Bytes read from the input * channel return as a ByteArray obj. * + * WARNING! The notion of "binary" used here is different from + * notions of "binary" used in other places. In particular, this + * "binary" routine may be called when an -eofchar is set on the + * channel. + * * Results: * Number of characters accumulated in the object or -1 if error, * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error @@ -4809,6 +4848,7 @@ TclGetsObjBinary( eolChar = (statePtr->inputTranslation == TCL_TRANSLATE_LF) ? '\n' : '\r'; + ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { /* * Subtract the number of bytes that were removed from channel @@ -4835,6 +4875,17 @@ TclGetsObjBinary( if (bufPtr == NULL) { goto restore; } + } else { + /* + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. + * A new CHANNEL_STICKY_EOF set in this routine leads to + * return before coming back here. When we are not dealing + * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an + * empty buffer. Here the buffer is non-empty so we know + * we're a non-EOF */ + + assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); + assert ( !GotFlag(statePtr, CHANNEL_EOF) ); } dst = (unsigned char *) RemovePoint(bufPtr); @@ -4876,6 +4927,7 @@ TclGetsObjBinary( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } if (GotFlag(statePtr, CHANNEL_EOF)) { skip = 0; @@ -4985,6 +5037,11 @@ TclGetsObjBinary( */ done: + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; @@ -5097,6 +5154,12 @@ FilterInputBytes( */ read: + if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED) + == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; + } if (GetInput(chanPtr) != 0) { gsPtr->charsWrote = 0; gsPtr->rawRead = 0; @@ -5109,6 +5172,17 @@ FilterInputBytes( gsPtr->rawRead = 0; return -1; } + } else { + /* + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. + * A new CHANNEL_STICKY_EOF set in this routine leads to + * return before coming back here. When we are not dealing + * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an + * empty buffer. Here the buffer is non-empty so we know + * we're a non-EOF */ + + assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); + assert ( !GotFlag(statePtr, CHANNEL_EOF) ); } /* @@ -5187,12 +5261,6 @@ FilterInputBytes( * some more, but avoid blocking on a non-blocking channel. */ - if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED) - == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) { - gsPtr->charsWrote = 0; - gsPtr->rawRead = 0; - return -1; - } goto read; } } else { @@ -5439,6 +5507,7 @@ Tcl_ReadRaw( /* State info for channel */ int copied = 0; + assert(bytesToRead > 0); if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) { return -1; } @@ -5470,8 +5539,19 @@ Tcl_ReadRaw( } } - /* Go to the driver if more data needed. */ + /* + * Go to the driver only if we got nothing from pushback. + * Have to do it this way to avoid EOF mis-timings when we + * consider the ability that EOF may not be a permanent + * condition in the driver, and in that case we have to + * synchronize. + */ + + if (copied) { + return copied; + } + /* This test not needed. */ if (bytesToRead > 0) { int nread = ChanRead(chanPtr, readBuf, bytesToRead); @@ -5494,12 +5574,10 @@ Tcl_ReadRaw( if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) { copied = -1; } - } else if (copied > 0) { + } else { /* - * nread == 0. Driver is at EOF, but if copied>0 bytes - * from pushback, then we should not signal it yet. + * nread == 0. Driver is at EOF. Let that state filter up. */ - ResetFlag(statePtr, CHANNEL_EOF); } } return copied; @@ -5598,19 +5676,11 @@ DoReadChars( ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int factor, copied, copiedNow, result; - Tcl_Encoding encoding; + int copied, copiedNow, result; + Tcl_Encoding encoding = statePtr->encoding; int binaryMode; #define UTF_EXPANSION_FACTOR 1024 - - /* - * This operation should occur at the top of a channel stack. - */ - - chanPtr = statePtr->topChanPtr; - encoding = statePtr->encoding; - factor = UTF_EXPANSION_FACTOR; - TclChannelPreserve((Tcl_Channel)chanPtr); + int factor = UTF_EXPANSION_FACTOR; binaryMode = (encoding == NULL) && (statePtr->inputTranslation == TCL_TRANSLATE_LF) @@ -5634,6 +5704,36 @@ DoReadChars( } } + /* + * Early out when next read will see eofchar. + * + * NOTE: See DoRead for argument that it's a bug (one we're keeping) + * to have this escape before the one for zero-char read request. + */ + + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + SetFlag(statePtr, CHANNEL_EOF); + assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); + assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + + UpdateInterest(chanPtr); + return 0; + } + + /* Special handling for zero-char read request. */ + if (toRead == 0) { + ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); + UpdateInterest(chanPtr); + return 0; + } + + /* + * This operation should occur at the top of a channel stack. + */ + + chanPtr = statePtr->topChanPtr; + TclChannelPreserve((Tcl_Channel)chanPtr); + /* Must clear the BLOCKED flag here since we check before reading */ ResetFlag(statePtr, CHANNEL_BLOCKED); for (copied = 0; (unsigned) toRead > 0; ) { @@ -5710,6 +5810,11 @@ DoReadChars( * Update the notifier state so we don't block while there is still data * in the buffers. */ + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return copied; @@ -6057,12 +6162,11 @@ ReadChars( /* * We read more chars than allowed. Reset limits to * prevent that and try again. Don't forget the extra - * padding of TCL_UTF_MAX - 1 bytes demanded by the + * padding of TCL_UTF_MAX bytes demanded by the * Tcl_ExternalToUtf() call! */ - dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) - + TCL_UTF_MAX - 1 - dst; + dstLimit = Tcl_UtfAtIndex(dst, charsToRead) + TCL_UTF_MAX - dst; statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; @@ -6319,7 +6423,7 @@ TranslateInputEOL( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; - ResetFlag(statePtr, INPUT_SAW_CR); + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } } @@ -6529,6 +6633,14 @@ GetInput( ChannelState *statePtr = chanPtr->state; /* State info for channel */ + /* + * Verify that all callers know better than to call us when + * it's recorded that the next char waiting to be read is the + * eofchar. + */ + + assert( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); + /* * Prevent reading from a dead channel -- a channel that has been closed * but not yet deallocated, which can happen if the exit handler for @@ -6540,18 +6652,24 @@ GetInput( return EINVAL; } - /* - * For a channel at EOF do not bother allocating buffers; there's - * nothing more to read. Avoid calling the driver inputproc in - * case some of them do not react well to additional calls after - * they've reported an eof state.. - * TODO: Candidate for a can't happen panic. + /* + * WARNING: There was once a comment here claiming that it was + * a bad idea to make another call to the inputproc of a channel + * driver when EOF has already been detected on the channel. Through + * much of Tcl's history, this warning was then completely negated + * by having all (most?) read paths clear the EOF setting before + * reaching here. So we had a guard that was never triggered. + * + * Don't be tempted to restore the guard. Even if EOF is set on + * the channel, continue through and call the inputproc again. This + * is the way to enable the ability to [read] again beyond the EOF, + * which seems a strange thing to do, but for which use cases exist + * [Tcl Bug 5adc350683] and which may even be essential for channels + * representing things like ttys or other devices where the stream + * might take the logical form of a series of 'files' separated by + * an EOF condition. */ - if (GotFlag(statePtr, CHANNEL_EOF)) { - return 0; - } - /* * First check for more buffers in the pushback area of the topmost * channel in the stack and use them. They can be the result of a @@ -6561,6 +6679,7 @@ GetInput( if (chanPtr->inQueueHead != NULL) { + /* TODO: Tests to cover this. */ assert(statePtr->inQueueHead == NULL); statePtr->inQueueHead = chanPtr->inQueueHead; @@ -6591,6 +6710,7 @@ GetInput( * Check the actual buffersize against the requested buffersize. * Saved buffers of the wrong size are squashed. This is done * to honor dynamic changes of the buffersize made by the user. + * TODO: Tests to cover this. */ if ((bufPtr != NULL) @@ -7108,9 +7228,7 @@ Tcl_Eof( ChannelState *statePtr = ((Channel *) chan)->state; /* State of real channel structure. */ - return (GotFlag(statePtr, CHANNEL_STICKY_EOF) || - (GotFlag(statePtr, CHANNEL_EOF) && - (Tcl_InputBuffered(chan) == 0))) ? 1 : 0; + return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; } /* @@ -8100,7 +8218,7 @@ Tcl_NotifyChannel( /* * Add this invocation to the list of recursive invocations of - * ChannelHandlerEventProc. + * Tcl_NotifyChannel. */ nh.nextHandlerPtr = NULL; @@ -8419,7 +8537,7 @@ Tcl_DeleteChannelHandler( } /* - * If ChannelHandlerEventProc is about to process this handler, tell it to + * If Tcl_NotifyChannel is about to process this handler, tell it to * process the next one instead - we are going to delete *this* one. */ @@ -9032,7 +9150,7 @@ MBRead( } code = GetInput(inStatePtr->topChanPtr); - if (code == 0) { + if (code == 0 || GotFlag(inStatePtr, CHANNEL_BLOCKED)) { return TCL_OK; } else { MBError(csPtr, TCL_READABLE, code); @@ -9282,6 +9400,10 @@ CopyData( csPtr); } if (size == 0) { + if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) { + /* We allowed a short read. Keep trying. */ + continue; + } if (bufObj != NULL) { TclDecrRefCount(bufObj); bufObj = NULL; @@ -9493,6 +9615,36 @@ DoRead( ChannelState *statePtr = chanPtr->state; char *p = dst; + assert (bytesToRead >= 0); + + /* + * Early out when we know a read will get the eofchar. + * + * NOTE: This seems to be a bug. The special handling for + * a zero-char read request ought to come first. As coded + * the EOF due to eofchar has distinguishing behavior from + * the EOF due to reported EOF on the underlying device, and + * that seems undesirable. However recent history indicates + * that new inconsistent behavior in a patchlevel has problems + * too. Keep on keeping on for now. + */ + + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + SetFlag(statePtr, CHANNEL_EOF); + assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); + assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + + UpdateInterest(chanPtr); + return 0; + } + + /* Special handling for zero-char read request. */ + if (bytesToRead == 0) { + ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); + UpdateInterest(chanPtr); + return 0; + } + TclChannelPreserve((Tcl_Channel)chanPtr); while (bytesToRead) { /* @@ -9504,31 +9656,39 @@ DoRead( ChannelBuffer *bufPtr = statePtr->inQueueHead; /* - * When there's no buffered data to read, and we're at EOF, - * escape to the caller. + * Don't read more data if we have what we need. */ - if (statePtr->flags & CHANNEL_EOF - && (bufPtr == NULL || IsBufferEmpty(bufPtr))) { - break; - } - - /* - * If there is not enough data in the buffers to possibly - * complete the read, then go get more. - */ + while (!bufPtr || /* We got no buffer! OR */ + (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ + (BytesLeft(bufPtr) < bytesToRead) ) ) { + /* Not enough bytes in it + * yet to fill the dst */ + int code; - if (bufPtr == NULL || BytesLeft(bufPtr) < bytesToRead) { moreData: - if (GetInput(chanPtr)) { + code = GetInput(chanPtr); + bufPtr = statePtr->inQueueHead; + + assert (bufPtr != NULL); + + if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) { + /* Further reads cannot do any more */ + break; + } + + if (code) { /* Read error */ UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return -1; } - bufPtr = statePtr->inQueueHead; + + assert (IsBufferFull(bufPtr)); } + assert (bufPtr != NULL); + bytesRead = BytesLeft(bufPtr); bytesWritten = bytesToRead; @@ -9555,8 +9715,7 @@ DoRead( * 1) We're @EOF because we saw eof char. */ - if (statePtr->inEofChar - && RemovePoint(bufPtr)[0] == statePtr->inEofChar) { + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { UpdateInterest(chanPtr); break; } @@ -9607,17 +9766,33 @@ DoRead( statePtr->inQueueTail = NULL; } RecycleBuffer(statePtr, bufPtr, 0); + bufPtr = statePtr->inQueueHead; } if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads) && GotFlag(statePtr, CHANNEL_BLOCKED)) { break; } + + /* + * When there's no buffered data to read, and we're at EOF, + * escape to the caller. + */ + + if (GotFlag(statePtr, CHANNEL_EOF) + && (bufPtr == NULL || IsBufferEmpty(bufPtr))) { + break; + } } if (bytesToRead == 0) { ResetFlag(statePtr, CHANNEL_BLOCKED); } + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); TclChannelRelease((Tcl_Channel)chanPtr); return (int)(p - dst); } diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 9c4347d..58d1a22 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -187,6 +187,7 @@ struct TransformChannelData { Tcl_Channel self; /* Our own Channel handle. */ int readIsFlushed; /* Flag to note whether in.flushProc was * called or not. */ + int eofPending; /* Flag: EOF seen down, not raised up */ int flags; /* Currently CHANNEL_ASYNC or zero. */ int watchMask; /* Current watch/event/interest mask. */ int mode; /* Mode of parent channel, OR'ed combination @@ -292,6 +293,7 @@ TclChannelTransform( Tcl_DStringInit(&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; dataPtr->flags = 0; if (ds.string[0] == '0') { dataPtr->flags |= CHANNEL_ASYNC; @@ -624,7 +626,7 @@ TransformInputProc( if (toRead == 0 || dataPtr->self == NULL) { /* - * Catch a no-op. + * Catch a no-op. TODO: Is this a panic()? */ return 0; } @@ -676,6 +678,17 @@ TransformInputProc( if (toRead <= 0) { break; } + if (dataPtr->eofPending) { + /* + * Already saw EOF from downChan; don't ask again. + * NOTE: Could move this up to avoid the last maxRead + * execution. Believe this would still be correct behavior, + * but the test suite tests the whole command callback + * sequence, so leave it unchanged for now. + */ + + break; + } /* * Get bytes from the underlying channel. @@ -711,14 +724,7 @@ TransformInputProc( * on the down channel. */ - if (dataPtr->readIsFlushed) { - /* - * Already flushed, nothing to do anymore. - */ - - break; - } - + dataPtr->eofPending = 1; dataPtr->readIsFlushed = 1; ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF, P_PRESERVE); @@ -746,8 +752,11 @@ TransformInputProc( break; } } /* while toRead > 0 */ - ReleaseData(dataPtr); + if (gotBytes == 0) { + dataPtr->eofPending = 0; + } + ReleaseData(dataPtr); return gotBytes; } @@ -858,6 +867,7 @@ TransformSeekProc( P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; } ReleaseData(dataPtr); @@ -931,6 +941,7 @@ TransformWideSeekProc( P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; } ReleaseData(dataPtr); diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 45ee08d..8baa9ad 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -161,6 +161,7 @@ typedef struct { int mode; /* Mask of R/W mode */ int nonblocking; /* Flag: Channel is blocking or not. */ int readIsDrained; /* Flag: Read buffers are flushed. */ + int eofPending; /* Flag: EOF seen down, but not raised up */ int dead; /* Boolean signal that some operations * should no longer be attempted. */ ResultBuffer result; @@ -1082,6 +1083,10 @@ ReflectInput( bufObj = Tcl_NewByteArrayObj(NULL, toRead); Tcl_IncrRefCount(bufObj); gotBytes = 0; + if (rtPtr->eofPending) { + goto stop; + } + rtPtr->readIsDrained = 0; while (toRead > 0) { /* * Loop until the request is satisfied (or no data available from @@ -1097,6 +1102,11 @@ ReflectInput( goto stop; } + if (rtPtr->eofPending) { + goto stop; + } + + /* * The buffer is exhausted, but the caller wants even more. We now * have to go to the underlying channel, get more bytes and then @@ -1165,11 +1175,9 @@ ReflectInput( * Zero returned from Tcl_ReadRaw() always indicates EOF * on the down channel. */ - - if (rtPtr->readIsDrained) { - goto stop; - } + rtPtr->eofPending = 1; + /* * Now this is a bit different. The partial data waiting is * converted and returned. @@ -1211,6 +1219,9 @@ ReflectInput( } /* while toRead > 0 */ stop: + if (gotBytes == 0) { + rtPtr->eofPending = 0; + } Tcl_DecrRefCount(bufObj); Tcl_Release(rtPtr); return gotBytes; @@ -1766,6 +1777,7 @@ NewReflectedTransform( rtPtr->timer = NULL; rtPtr->mode = 0; rtPtr->readIsDrained = 0; + rtPtr->eofPending = 0; rtPtr->nonblocking = (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING); rtPtr->dead = 0; @@ -3318,6 +3330,7 @@ TransformClear( (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL); rtPtr->readIsDrained = 0; + rtPtr->eofPending = 0; ResultClear(&rtPtr->result); } diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 694501f..f69d30f 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -12,9 +12,26 @@ #include "tclInt.h" #if defined(_WIN32) && defined(UNICODE) -/* On Windows, we always need the ASCII version. */ -# undef gai_strerror -# define gai_strerror gai_strerrorA +/* On Windows, we need to do proper Unicode->UTF-8 conversion. */ + +typedef struct ThreadSpecificData { + int initialized; + Tcl_DString errorMsg; /* UTF-8 encoded error-message */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + +#undef gai_strerror +static const char *gai_strerror(int code) { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->initialized) { + Tcl_DStringFree(&tsdPtr->errorMsg); + } else { + tsdPtr->initialized = 1; + } + Tcl_WinTCharToUtf(gai_strerrorW(code), -1, &tsdPtr->errorMsg); + return Tcl_DStringValue(&tsdPtr->errorMsg); +} #endif /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 6bf1ef9..860c2a3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1741,7 +1741,7 @@ enum PkgPreferOptions { * definition there. * Some macros require knowledge of some fields in the struct in order to * avoid hitting the TSD unnecessarily. In order to facilitate this, a pointer - * to the relevant fields is kept in the objCache field in struct Interp. + * to the relevant fields is kept in the allocCache field in struct Interp. *---------------------------------------------------------------- */ @@ -3095,7 +3095,8 @@ MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, - int reStrLen, Tcl_DString *dsPtr, int *flagsPtr); + int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, + int *quantifiersFoundPtr); MODULE_SCOPE int TclScanElement(const char *string, int length, int *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, diff --git a/generic/tclOO.c b/generic/tclOO.c index ace47fe..77e668b 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1287,7 +1287,9 @@ TclOORemoveFromInstances( removeInstance: if (Deleted(clsPtr->thisPtr)) { - DelRef(clsPtr->instances.list[i]); + if (!IsRootClass(clsPtr)) { + DelRef(clsPtr->instances.list[i]); + } clsPtr->instances.list[i] = NULL; } else { clsPtr->instances.num--; diff --git a/generic/tclOO.h b/generic/tclOO.h index 24d3e6f..a7116dc 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,7 +24,7 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0.2" +#define TCLOO_VERSION "1.0.3" #define TCLOO_PATCHLEVEL TCLOO_VERSION #include "tcl.h" diff --git a/generic/tclProc.c b/generic/tclProc.c index ce1c767..e0d6ec7 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -15,7 +15,6 @@ #include "tclInt.h" #include "tclCompile.h" -#include "tclOOInt.h" /* * Variables that are part of the [apply] command implementation and which @@ -41,9 +40,6 @@ static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, Namespace *nsPtr); static void InitLocalCache(Proc *procPtr); -static int PushProcCallFrame(ClientData clientData, - register Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int isLambda); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); @@ -92,10 +88,10 @@ static const Tcl_ObjType levelReferenceType = { * * Internally, ptr1 is a pointer to a Proc instance that is not bound to a * command name, and ptr2 is a pointer to the namespace that the Proc instance - * will execute within. + * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. */ -static const Tcl_ObjType lambdaType = { +const Tcl_ObjType tclLambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ @@ -221,7 +217,7 @@ Tcl_ProcObjCmd( * * This code is nearly identical to the #280 code in SetLambdaFromAny, see * this file. The differences are the different index of the body in the - * line array of the context, and the lamdba code requires some special + * line array of the context, and the lambda code requires some special * processing. Find a way to factor the common elements into a single * function. */ @@ -1571,7 +1567,7 @@ InitArgsAndLocals( /* *---------------------------------------------------------------------- * - * PushProcCallFrame -- + * TclPushProcCallFrame -- * * Compiles a proc body if necessary, then pushes a CallFrame suitable * for executing it. @@ -1586,8 +1582,8 @@ InitArgsAndLocals( *---------------------------------------------------------------------- */ -static int -PushProcCallFrame( +int +TclPushProcCallFrame( ClientData clientData, /* Record describing procedure to be * interpreted. */ register Tcl_Interp *interp,/* Interpreter in which procedure was @@ -1708,7 +1704,7 @@ TclNRInterpProc( * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { - int result = PushProcCallFrame(clientData, interp, objc, objv, + int result = TclPushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); if (result != TCL_OK) { @@ -2443,7 +2439,7 @@ DupLambdaInternalRep( procPtr->refCount++; Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &lambdaType; + copyPtr->typePtr = &tclLambdaType; } static void @@ -2480,7 +2476,7 @@ SetLambdaFromAny( /* * Convert objPtr to list type first; if it cannot be converted, or if its - * length is not 2, then it cannot be converted to lambdaType. + * length is not 2, then it cannot be converted to tclLambdaType. */ result = TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -2626,14 +2622,14 @@ SetLambdaFromAny( /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to lambdaType. + * conversion to tclLambdaType. */ TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = procPtr; objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - objPtr->typePtr = &lambdaType; + objPtr->typePtr = &tclLambdaType; return TCL_OK; } @@ -2684,12 +2680,12 @@ TclNRApplyObjCmd( } /* - * Set lambdaPtr, convert it to lambdaType in the current interp if + * Set lambdaPtr, convert it to tclLambdaType in the current interp if * necessary. */ lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &lambdaType) { + if (lambdaPtr->typePtr == &tclLambdaType) { procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } @@ -2767,7 +2763,7 @@ TclNRApplyObjCmd( } extraPtr->isRootEnsemble = isRootEnsemble; - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); + result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); if (result == TCL_OK) { TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); @@ -2827,234 +2823,6 @@ MakeLambdaError( } /* - *---------------------------------------------------------------------- - * - * Tcl_DisassembleObjCmd -- - * - * Implementation of the "::tcl::unsupported::disassemble" command. This - * command is not documented, but will disassemble procedures, lambda - * terms and general scripts. Note that will compile terms if necessary - * in order to disassemble them. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_DisassembleObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const types[] = { - "lambda", "method", "objmethod", "proc", "script", NULL - }; - enum Types { - DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, - DISAS_SCRIPT - }; - int idx, result; - Tcl_Obj *codeObjPtr = NULL; - Proc *procPtr = NULL; - Tcl_HashEntry *hPtr; - Object *oPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "type ..."); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ - return TCL_ERROR; - } - - switch ((enum Types) idx) { - case DISAS_LAMBDA: { - Command cmd; - Tcl_Obj *nsObjPtr; - Tcl_Namespace *nsPtr; - - /* - * Compile (if uncompiled) and disassemble a lambda term. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); - return TCL_ERROR; - } - if (objv[2]->typePtr == &lambdaType) { - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { - result = SetLambdaFromAny(interp, objv[2]); - if (result != TCL_OK) { - return result; - } - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - - memset(&cmd, 0, sizeof(Command)); - nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return result; - } - cmd.nsPtr = (Namespace *) nsPtr; - procPtr->cmdPtr = &cmd; - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - } - case DISAS_PROC: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procName"); - return TCL_ERROR; - } - - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - /* - * Compile (if uncompiled) and disassemble a procedure. - */ - - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - case DISAS_SCRIPT: - /* - * Compile and disassemble a script. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script"); - return TCL_ERROR; - } - if ((objv[2]->typePtr != &tclByteCodeType) - && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { - return TCL_ERROR; - } - codeObjPtr = objv[2]; - break; - - case DISAS_CLASS_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of a class method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) objv[3]); - goto methodBody; - case DISAS_OBJECT_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of an instance method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->methodsPtr == NULL) { - goto unknownMethod; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); - - /* - * Compile (if necessary) and disassemble a method body. - */ - - methodBody: - if (hPtr == NULL) { - unknownMethod: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[3]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[3]), NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "body not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); - return TCL_ERROR; - } - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of method", - TclGetString(objv[3])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; - default: - CLANG_ASSERT(0); - } - - /* - * Do the actual disassembly. - */ - - if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags - & TCL_BYTECODE_PRECOMPILED) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not disassemble prebuilt bytecode", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "BYTECODE", NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); - return TCL_OK; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 6348e4a..5bc3aa2 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -946,7 +946,8 @@ CompileRegexp( * Tcl_RegExpExecObj to optionally do a fast match (avoids RE engine). */ - if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) { + if (TclReToGlob(NULL, string, length, &stringBuf, &exact, + NULL) == TCL_OK) { regexpPtr->globObjPtr = TclDStringToObj(&stringBuf); Tcl_IncrRefCount(regexpPtr->globObjPtr); } else { diff --git a/generic/tclThread.c b/generic/tclThread.c index 8c972a8..5ac6a8d 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -357,7 +357,12 @@ TclFinalizeThreadData(void) { TclFinalizeThreadDataThread(); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclFinalizeThreadAllocThread(); + if ((!TclInExit())||TclFullFinalizationRequested()) { + /* + * Quick exit principle makes it useless to terminate allocators + */ + TclFinalizeThreadAllocThread(); + } #endif } diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index ddf888a..560556d 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -217,10 +217,11 @@ GetCache(void) cachePtr = TclpGetAllocCache(); if (cachePtr == NULL) { - cachePtr = calloc(1, sizeof(Cache)); + cachePtr = TclpSysAlloc(sizeof(Cache), 0); if (cachePtr == NULL) { Tcl_Panic("alloc: could not allocate new cache"); } + memset(cachePtr, 0, sizeof(Cache)); Tcl_MutexLock(listLockPtr); cachePtr->nextPtr = firstCachePtr; firstCachePtr = cachePtr; @@ -287,7 +288,7 @@ TclFreeAllocCache( *nextPtrPtr = cachePtr->nextPtr; cachePtr->nextPtr = NULL; Tcl_MutexUnlock(listLockPtr); - free(cachePtr); + TclpSysFree(cachePtr); } /* @@ -332,7 +333,7 @@ TclpAlloc( /* * Increment the requested size to include room for the Block structure. - * Call malloc() directly if the required amount is greater than the + * Call TclpSysAlloc() directly if the required amount is greater than the * largest block, otherwise pop the smallest block large enough, * allocating more blocks if necessary. */ @@ -344,7 +345,7 @@ TclpAlloc( #endif if (size > MAXALLOC) { bucket = NBUCKETS; - blockPtr = malloc(size); + blockPtr = TclpSysAlloc(size, 0); if (blockPtr != NULL) { cachePtr->totalAssigned += reqSize; } @@ -407,7 +408,7 @@ TclpFree( bucket = blockPtr->sourceBucket; if (bucket == NBUCKETS) { cachePtr->totalAssigned -= blockPtr->blockReqSize; - free(blockPtr); + TclpSysFree(blockPtr); return; } @@ -472,7 +473,7 @@ TclpRealloc( /* * If the block is not a system block and fits in place, simply return the * existing pointer. Otherwise, if the block is a system block and the new - * size would also require a system block, call realloc() directly. + * size would also require a system block, call TclpSysRealloc() directly. */ blockPtr = Ptr2Block(ptr); @@ -495,7 +496,7 @@ TclpRealloc( } else if (size > MAXALLOC) { cachePtr->totalAssigned -= blockPtr->blockReqSize; cachePtr->totalAssigned += reqSize; - blockPtr = realloc(blockPtr, size); + blockPtr = TclpSysRealloc(blockPtr, size); if (blockPtr == NULL) { return NULL; } @@ -567,7 +568,7 @@ TclThreadAllocObj(void) Tcl_Obj *newObjsPtr; cachePtr->numObjects = numMove = NOBJALLOC; - newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); + newObjsPtr = TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %d new objects", numMove); } @@ -964,7 +965,7 @@ GetBlocks( if (blockPtr == NULL) { size = MAXALLOC; - blockPtr = malloc(size); + blockPtr = TclpSysAlloc(size, 0); if (blockPtr == NULL) { return 0; } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index c0cde49..6184a89 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -2511,6 +2511,9 @@ TclObjCallVarTraces( if (!part1Ptr) { part1Ptr = localName(iPtr->varFramePtr, index); } + if (!part1Ptr) { + Tcl_Panic("Cannot trace a variable with no name"); + } part1 = TclGetString(part1Ptr); part2 = part2Ptr? TclGetString(part2Ptr) : NULL; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index ae3adae..64589a2 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4249,7 +4249,8 @@ TclReToGlob( const char *reStr, int reStrLen, Tcl_DString *dsPtr, - int *exactPtr) + int *exactPtr, + int *quantifiersFoundPtr) { int anchorLeft, anchorRight, lastIsStar, numStars; char *dsStr, *dsStrStart; @@ -4257,6 +4258,9 @@ TclReToGlob( strEnd = reStr + reStrLen; Tcl_DStringInit(dsPtr); + if (quantifiersFoundPtr != NULL) { + *quantifiersFoundPtr = 0; + } /* * "***=xxx" == "*xxx*", watch for glob-sensitive chars. @@ -4369,6 +4373,9 @@ TclReToGlob( } break; case '.': + if (quantifiersFoundPtr != NULL) { + *quantifiersFoundPtr = 1; + } anchorLeft = 0; /* prevent exact match */ if (p+1 < strEnd) { if (p[1] == '*') { diff --git a/generic/tclVar.c b/generic/tclVar.c index 5e3157e..ec4c13c 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -4405,8 +4405,8 @@ ObjMakeUpvar( || !HasLocalVars(varFramePtr) || (strstr(TclGetString(myNamePtr), "::") != NULL))) { Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( - "bad variable name \"%s\": upvar won't create " - "namespace variable that refers to procedure variable", + "bad variable name \"%s\": can't create namespace " + "variable that refers to procedure variable", TclGetString(myNamePtr))); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); return TCL_ERROR; @@ -4506,9 +4506,8 @@ TclPtrObjMakeUpvar( */ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( - "bad variable name \"%s\": upvar won't create a" - " scalar variable that looks like an array element", - myName)); + "bad variable name \"%s\": can't create a scalar " + "variable that looks like an array element", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); return TCL_ERROR; diff --git a/library/init.tcl b/library/init.tcl index 265f928..f1f7704 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6.2 +package require -exact Tcl 8.6.3 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/license.terms b/license.terms index 164d65e..d8049cd 100644 --- a/license.terms +++ b/license.terms @@ -29,7 +29,7 @@ MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" -in the software and related documentation as defined in the Federal +in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the @@ -37,4 +37,4 @@ Government shall have only "Restricted Rights" as defined in Clause 252.227-7014 (b) (3) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the -terms specified in this license. +terms specified in this license. diff --git a/macosx/configure.ac b/macosx/configure.ac index 01c3697..f7a8bb3 100644 --- a/macosx/configure.ac +++ b/macosx/configure.ac @@ -3,7 +3,7 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. -dnl Ensure that the config (auto)headers support is used, then just +dnl Ensure that the config (auto)headers support is used, then just dnl include the configure sources from ../unix: m4_include(../unix/aclocal.m4) diff --git a/pkgs/README b/pkgs/README index 868bd4f..159a237 100644 --- a/pkgs/README +++ b/pkgs/README @@ -36,14 +36,14 @@ needs to conform to the following conventions. clean: Delete all files generated by the default build target. - distclean: Delete all generated files. + distclean: Delete all generated files. dist: Produce a copy of the package's source code distribution. Must respect the DIST_ROOT variable determining where to write the generated directory. Packages that are written to make use of the Tcl Extension Architecture (TEA) -and that make use of the tclconfig collection of support files, should +and that make use of the tclconfig collection of support files, should conform to these conventions without further efforts. These conventions are subject to revision and refinement over time to diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test new file mode 100644 index 0000000..3ba5167 --- /dev/null +++ b/tests/aaa_exit.test @@ -0,0 +1,54 @@ +# Commands covered: exit, emphasis on finalization hangs +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +test exit-1.1 {normal, quick exit} { + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r] + set aft [after 1000 {set done "Quick exit hangs !!!"}] + fileevent $f readable {after cancel $aft;set done OK} + vwait done + if {$done != "OK"} { + fconfigure $f -blocking 0 + close $f + } else { + if {[catch {close $f} err]} { + set done "Quick exit misbehaves: $err" + } + } + set done +} OK + +test exit-1.2 {full-finalized exit} { + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\"" r] + set aft [after 1000 {set done "Full-finalized exit hangs !!!"}] + fileevent $f readable {after cancel $aft;set done OK} + vwait done + if {$done != "OK"} { + fconfigure $f -blocking 0 + close $f + } else { + if {[catch {close $f} err]} { + set done "Full-finalized exit misbehaves: $err" + } + } + set done +} OK + + +# cleanup +::tcltest::cleanupTests +return diff --git a/tests/append.test b/tests/append.test index 69c6381..8fa4e61 100644 --- a/tests/append.test +++ b/tests/append.test @@ -292,6 +292,23 @@ test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env } -cleanup { unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} + +test append-10.1 {Bug 214cc0eb22: lappend with no values} { + set lst "# 1 2 3" + [subst lappend] lst +} "# 1 2 3" +test append-10.2 {Bug 214cc0eb22: lappend with no values} -body { + set lst "1 \{ 2" + [subst lappend] lst +} -returnCodes error -result {unmatched open brace in list} +test append-10.3 {Bug 214cc0eb22: expanded lappend with no values} { + set lst "# 1 2 3" + [subst lappend] lst {*}[list] +} "# 1 2 3" +test append-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body { + set lst "1 \{ 2" + [subst lappend] lst {*}[list] +} -returnCodes error -result {unmatched open brace in list} unset -nocomplain i x result y catch {rename foo ""} diff --git a/tests/appendComp.test b/tests/appendComp.test index f85c3ba..bbf5f9c 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -438,6 +438,27 @@ test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing } -cleanup { unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} + +test appendComp-10.1 {Bug 214cc0eb22: lappend with no values} { + apply {lst { + lappend lst + }} "# 1 2 3" +} "# 1 2 3" +test appendComp-10.2 {Bug 214cc0eb22: lappend with no values} -body { + apply {lst { + lappend lst + }} "1 \{ 2" +} -returnCodes error -result {unmatched open brace in list} +test appendComp-10.3 {Bug 214cc0eb22: expanded lappend with no values} { + apply {lst { + lappend lst {*}[list] + }} "# 1 2 3" +} "# 1 2 3" +test appendComp-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body { + apply {lst { + lappend lst {*}[list] + }} "1 \{ 2" +} -returnCodes error -result {unmatched open brace in list} catch {unset i x result y} catch {rename foo ""} diff --git a/tests/compile.test b/tests/compile.test index 2852bf2..22ebc7d 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -658,12 +658,15 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup # does not check the format of disassembled bytecode though; that's liable to # change without warning. +set disassemblables [linsert [join { + lambda method objmethod proc script +} ", "] end-1 or] test compile-18.1 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble } -match glob -result {wrong # args: should be "*"} test compile-18.2 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble ? -} -match glob -result {bad type "?": must be *} +} -result "bad type \"?\": must be $disassemblables" test compile-18.3 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble lambda } -match glob -result {wrong # args: should be "* lambda lambdaTerm"} @@ -737,6 +740,83 @@ test compile-18.19 {disassembler - basics} -setup { } -cleanup { foo destroy } -match glob -result * +# There never was a compile-18.20. +# The keys of the dictionary produced by [getbytecode] are defined. +set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth} +test compile-18.21 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode +} -match glob -result {wrong # args: should be "*"} +test compile-18.22 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode ? +} -result "bad type \"?\": must be $disassemblables" +test compile-18.23 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode lambda +} -match glob -result {wrong # args: should be "* lambda lambdaTerm"} +test compile-18.24 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode lambda \{ +} -result "can't interpret \"\{\" as a lambda expression" +test compile-18.25 {disassembler - basics} -body { + dict keys [tcl::unsupported::getbytecode lambda {{} {}}] +} -result $bytecodekeys +test compile-18.26 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode proc +} -match glob -result {wrong # args: should be "* proc procName"} +test compile-18.27 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode proc nosuchproc +} -result {"nosuchproc" isn't a procedure} +test compile-18.28 {disassembler - basics} -setup { + proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result $bytecodekeys +test compile-18.29 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode script +} -match glob -result {wrong # args: should be "* script script"} +test compile-18.30 {disassembler - basics} -body { + dict keys [tcl::unsupported::getbytecode script {}] +} -result $bytecodekeys +test compile-18.31 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method +} -match glob -result {wrong # args: should be "* method className methodName"} +test compile-18.32 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method nosuchclass foo +} -result {nosuchclass does not refer to an object} +test compile-18.33 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::getbytecode method justanobject foo +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.34 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.35 {disassembler - basics} -setup { + oo::class create foo {method bar {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode method foo bar] +} -cleanup { + foo destroy +} -result $bytecodekeys +test compile-18.36 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod +} -match glob -result {wrong # args: should be "* objmethod objectName methodName"} +test compile-18.37 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod nosuchobject foo +} -result {nosuchobject does not refer to an object} +test compile-18.38 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.39 {disassembler - basics} -setup { + oo::object create foo + oo::objdefine foo {method bar {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode objmethod foo bar] +} -cleanup { + foo destroy +} -result $bytecodekeys test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { # This will panic in a --enable-symbols=compile build, unless bug is fixed. diff --git a/tests/coroutine.test b/tests/coroutine.test index 05b58c9..205da67 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -726,6 +726,20 @@ test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup { catch {namespace delete ::cotest} catch {rename cotest ""} } -result {yieldto called in deleted namespace} +test coroutine-7.12 {coro floor above street level #3008307} -body { + proc c {} { + yield + } + proc cc {} { + coroutine C c + } + proc boom {} { + cc ; # coro created at level 2 + C ; # and called at level 1 + } + boom ; # does not crash: the coro floor is a good insulator + list +} -result {} # cleanup diff --git a/tests/error.test b/tests/error.test index 0de644c..af07ed7 100644 --- a/tests/error.test +++ b/tests/error.test @@ -1184,6 +1184,12 @@ test error-21.8 {memory leaks in try: Bug 2910044} memory { } } 0 +test error-21.9 {Bug cee90e4e88} { + # Just don't panic. + apply {{} {try {} on ok {} - on return {} {}}} +} {} + + # negative case try tests - bad "trap" handler # what is the effect if we attempt to trap an errorcode that is not a list? # nested try diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 942a86c..9fe4fe9 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -513,6 +513,9 @@ test filesystem-6.32 {empty file name} -returnCodes error -body { file type "" } -result {could not read "": no such file or directory} test filesystem-6.33 {empty file name} {file writable ""} 0 +test filesystem-6.34 {file name with (invalid) nul character} { + list [catch "open foo\x00" msg] $msg +} [list 1 "couldn't open \"foo\x00\": filename is invalid on this platform"] # Make sure the testfilesystem hasn't been registered. if {[testConstraint testfilesystem]} { diff --git a/tests/interp.test b/tests/interp.test index ad99fac..4bc9fe2 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -3615,10 +3615,10 @@ test interp-38.3 {interp debug wrong args} -body { } -returnCodes { error } -result {wrong # args: should be "interp debug path ?-frame ?bool??"} -test interp-38.4 {interp debug basic setup} -body { +test interp-38.4 {interp debug basic setup} -constraints {!singleTestInterp} -body { interp debug {} } -result {-frame 0} -test interp-38.5 {interp debug basic setup} -body { +test interp-38.5 {interp debug basic setup} -constraints {!singleTestInterp} -body { interp debug {} -f } -result {0} test interp-38.6 {interp debug basic setup} -body { diff --git a/tests/io.test b/tests/io.test index 639691a..b09d55a 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1484,6 +1484,39 @@ test io-12.6 {ReadChars: too many chars read} { } close $c } {} +test io-12.7 {ReadChars: too many chars read [bc5b790099]} { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat \uBEEF 10]....\uBEEF] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 + while {![eof $c]} { + read $c 7 + } + close $c +} {} test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] @@ -4292,6 +4325,110 @@ test io-33.10 {Tcl_Gets, exercising double buffering} { close $f set y } 300 +test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 3} {set n 3} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -translation binary -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result {{} {} {} .......} +test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 3} {set n 3} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result {{} {} {} .......} +test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [string repeat \ + [string repeat . 64]\n[string repeat . 25] 2] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 65} {set n 65} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result [list [string repeat . 64] {} [string repeat . 89] \ + [string repeat . 25] {}] # Test Tcl_Seek and Tcl_Tell. @@ -7675,6 +7812,94 @@ test io-53.14 {TclCopyChannel: write error reporting} -setup { removeFile in rename driver {} } -result {error writing "*": *} -returnCodes error -match glob +test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { + proc driver {cmd args} { + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 +} -body { + chan copy $c $outChan +} -cleanup { + close $outChan + close $c + removeFile out +} -result 100 +test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup { + proc driver {cmd args} { + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 -translation lf + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 -translation lf +} -body { + chan copy $c $outChan +} -cleanup { + close $outChan + close $c + removeFile out +} -result 100 test io-54.1 {Recursive channel events} {socket fileevent} { # This test checks to see if file events are delivered during recursive @@ -8240,6 +8465,26 @@ test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup { close $f } -result {1 {can not find channel named "@@"}} +test io-73.3 {[5adc350683] [gets] after EOF} -setup { + set fn [makeFile {} io-73.3] + set rfd [open $fn r] + set wfd [open $fn a] + chan configure $wfd -buffering line + read $rfd +} -body { + set result [eof $rfd] + puts $wfd "more data" + lappend result [eof $rfd] + lappend result [gets $rfd] + lappend result [eof $rfd] + lappend result [gets $rfd] + lappend result [eof $rfd] +} -cleanup { + close $wfd + close $rfd + removeFile io-73.3 +} -result {1 1 {more data} 0 {} 1} + # ### ### ### ######### ######### ######### # cleanup diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 53078f7..e179eab 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -598,6 +598,179 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup { } -result {{read rt* {test data }} {}} +# Driver for a base channel that emits several short "files" +# with each terminated by a fleeting EOF + proc driver {cmd args} { + variable ::tcl::buffer + variable ::tcl::index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ..... + return {initialize finalize watch read} + } + finalize { + if {![info exists index($chan)]} {return} + unset index($chan) buffer($chan) + array unset index + array unset buffer + return + } + watch {} + read { + set n [lindex $args 1] + if {![info exists index($chan)]} { + driver initialize $chan + } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + if {[string length $result] == 0} { + driver finalize $chan + } + return $result + } + } + } + +# Channel read transform that is just the identity - pass all through + proc idxform {cmd handle args} { + switch -- $cmd { + initialize { + return {initialize finalize read} + } + finalize { + return + } + read { + lassign $args buffer + return $buffer + } + } + } + +# Test that all EOFs pass through full xform stack. Proper data boundaries. +# Check robustness against buffer sizes. +test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.10.1 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + chan configure $chan -buffersize 3 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.10.2 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + chan configure $chan -buffersize 5 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + +rename idxform {} + +# Channel read transform that delays the data and always returns something + proc delayxform {cmd handle args} { + variable store + switch -- $cmd { + initialize { + set store($handle) {} + return {initialize finalize read drain} + } + finalize { + unset store($handle) + return + } + read { + lassign $args buffer + if {$store($handle) eq {}} { + set reply [string index $buffer 0] + set store($handle) [string range $buffer 1 end] + } else { + set reply $store($handle) + set store($handle) $buffer + } + return $reply + } + drain { + delayxform read $handle {} + } + } + } + +# Test that all EOFs pass through full xform stack. Proper data boundaries. +# Check robustness against buffer sizes. +test iortrans-4.11 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.11.1 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + chan configure $chan -buffersize 3 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.11.2 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + chan configure $chan -buffersize 5 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + + rename delayxform {} + +# Channel read transform that delays the data and may return {} + proc delay2xform {cmd handle args} { + variable store + switch -- $cmd { + initialize { + set store($handle) {} + return {initialize finalize read drain} + } + finalize { + unset store($handle) + return + } + read { + lassign $args buffer + set reply $store($handle) + set store($handle) $buffer + return $reply + } + drain { + delay2xform read $handle {} + } + } + } + +test iortrans-4.12 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delay2xform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + + rename delay2xform {} + rename driver {} + + # --- === *** ########################### # method write (via puts) diff --git a/tests/iogt.test b/tests/iogt.test index 6cc0542..1ed89f7 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -871,6 +871,80 @@ test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { close $f } -result {xxxghi} + +# Driver for a base channel that emits several short "files" +# with each terminated by a fleeting EOF + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ..... + return {initialize finalize watch read} + } + finalize { + if {![info exists index($chan)]} {return} + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {![info exists index($chan)]} { + driver initialize $chan + } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + if {[string length $result] == 0} { + driver finalize $chan + } + return $result + } + } + } + +test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body { + set chan [chan create read [namespace which driver]] + identity -attach $chan + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + +proc delay {op data} { + variable store + switch -- $op { + create/write - create/read - + delete/write - delete/read - + flush/write - write - + clear_read {;#ignore} + flush/read - + read { + if {![info exists store]} {set store {}} + set reply $store + set store $data + return $reply + } + query/maxRead {return -1} + } +} + +test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body { + set chan [chan create read [namespace which driver]] + testchannel transform $chan -command [namespace code delay] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + +rename delay {} +rename driver {} + # cleanup foreach file [list dummy dummyout __echo_srv__.tcl] { removeFile $file diff --git a/tests/lreplace.test b/tests/lreplace.test index 5f675bc..b976788 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -15,7 +15,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } - + test lreplace-1.1 {lreplace command} { lreplace {1 2 3 4 5} 0 0 a } {a 2 3 4 5} @@ -130,7 +130,19 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} { p } "a b c" +test lreplace-4.1 {Bug ccc2c2cc98: lreplace edge case} { + lreplace {} 1 1 +} {} +# Note that this test will fail in 8.5 +test lreplace-4.2 {Bug ccc2c2cc98: lreplace edge case} { + lreplace { } 1 1 +} {} + # cleanup catch {unset foo} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/oo.test b/tests/oo.test index 8c515da..5fa760b 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.1 +package require TclOO 1.0.3 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* @@ -271,6 +271,16 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup { } -cleanup { rename test-oo-1.18 {} } -result 0 +test oo-1.18.2 {Bug 21c144f0f5} -setup { + interp create slave +} -body { + slave eval { + oo::define [oo::class create foo] superclass oo::class + oo::class destroy + } +} -cleanup { + interp delete slave +} test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o namespace delete [info object namespace o] diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 9a63577..5ecd209 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.1 +package require TclOO 1.0.3 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/parse.test b/tests/parse.test index fe6026d..5d8afeb 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -303,8 +303,10 @@ test parse-6.16 {ParseTokens procedure, backslash substitution} testparser { testparser {\n\a\x7f} 0 } {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}} test parse-6.17 {ParseTokens procedure, null characters} {testparser testbytestring} { - testparser [testbytestring "foo\0zz"] 0 -} "- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}" + expr {[testparser [testbytestring "foo\0zz"] 0] eq +"- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}" + } +} 1 test parse-6.18 {ParseTokens procedure, seek past numBytes for close-bracket} testparser { # Test for Bug 681841 list [catch {testparser {[a]} 2} msg] $msg @@ -916,7 +918,7 @@ test parse-15.57 {CommandComplete procedure} { test parse-15.58 {CommandComplete procedure, memory leaks} { info complete "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22" } 1 -test parse-15.59 {CommandComplete procedure} { +test parse-15.59 {CommandComplete procedure} testbytestring { # Test for Tcl Bug 684744 info complete [testbytestring "\x00;if 1 \{"] } 0 diff --git a/tests/parseOld.test b/tests/parseOld.test index 4c08b5d..a6e07a2b 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -263,14 +263,14 @@ test parseOld-7.11 {backslash substitution} { eval "list a \"b c\"\\\nd e" } {a {b c} d e} test parseOld-7.12 {backslash substitution} testbytestring { - list \ua2 -} [testbytestring "\xc2\xa2"] + expr {[list \ua2] eq [testbytestring "\xc2\xa2"]} +} 1 test parseOld-7.13 {backslash substitution} testbytestring { - list \u4e21 -} [testbytestring "\xe4\xb8\xa1"] + expr {[list \u4e21] eq [testbytestring "\xe4\xb8\xa1"]} +} 1 test parseOld-7.14 {backslash substitution} testbytestring { - list \u4e2k -} [testbytestring "\xd3\xa2k"] + expr {[list \u4e2k] eq [testbytestring "\xd3\xa2k"]} +} 1 # Semi-colon. diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 7be1195..01ef06d 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -526,6 +526,11 @@ test regexpComp-9.6 {-all option to regsub} { list [regsub -all ^ xxx 123 foo] $foo } } {1 123xxx} +test regexpComp-9.7 {Bug 84af1192f5: -all option to regsub} { + evalInProc { + regsub -all {\(.*} 123(qwe) "" + } +} 123 test regexpComp-10.1 {expanded syntax in regsub} { evalInProc { diff --git a/tests/socket.test b/tests/socket.test index c50730c..eeea044 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -2249,7 +2249,7 @@ test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener unset x } -result {socket is not connected} -returnCodes 1 test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ - -constraints {socket} \ + -constraints {socket nonportable} \ -body { set sock [socket -async localhost [randport]] fconfigure $sock -blocking 0 @@ -2321,6 +2321,28 @@ test socket-14.15 {blocking read on async socket should not trigger event handle set x } -result ok +# v4 and v6 is required to prevent that the async connect does not terminate +# before the fconfigure command. There is always an additional ip to try. +test socket-14.16 {empty -peername while [socket -async] connecting} \ + -constraints {socket localhost_v4 localhost_v6} \ + -body { + set client [socket -async localhost [randport]] + fconfigure $client -peername + } -cleanup { + catch {close $client} + } -result {} + +# v4 and v6 is required to prevent that the async connect does not terminate +# before the fconfigure command. There is always an additional ip to try. +test socket-14.17 {empty -sockname while [socket -async] connecting} \ + -constraints {socket localhost_v4 localhost_v6} \ + -body { + set client [socket -async localhost [randport]] + fconfigure $client -sockname + } -cleanup { + catch {close $client} + } -result {} + set num 0 set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}} diff --git a/tests/subst.test b/tests/subst.test index 256b7f7..2115772 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -38,8 +38,8 @@ test subst-2.3 {simple strings} { } abcdefg test subst-2.4 {simple strings} testbytestring { # Tcl Bug 685106 - subst [testbytestring bar\x00soom] -} [testbytestring bar\x00soom] + expr {[subst [testbytestring bar\x00soom]] eq [testbytestring bar\x00soom]} +} 1 test subst-3.1 {backslash substitutions} { subst {\x\$x\[foo bar]\\} diff --git a/tests/upvar.test b/tests/upvar.test index e93f58a..5ea870d 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -339,7 +339,7 @@ test upvar-8.9 {upvar won't create namespace variable that refers to procedure v unset ::test_ns_1::a } MakeLink 1 -} -result {bad variable name "a": upvar won't create namespace variable that refers to procedure variable} +} -result {bad variable name "a": can't create namespace variable that refers to procedure variable} test upvar-8.10 {upvar will create element alias for new array element} -setup { catch {unset upvarArray} } -body { @@ -578,7 +578,6 @@ test upvar-NS-3.3 {CompileWord OBOE} -setup { } -cleanup { rename linenumber {} } -result 1 - # cleanup ::tcltest::cleanupTests diff --git a/tests/utf.test b/tests/utf.test index 2fcac49..ceb1af7 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -21,23 +21,23 @@ testConstraint testbytestring [llength [info commands testbytestring]] catch {unset x} test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring { - set x \x01 -} [testbytestring "\x01"] + expr {"\x01" eq [testbytestring "\x01"]} +} 1 test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { - set x "\x00" -} [testbytestring "\xc0\x80"] + expr {"\x00" eq [testbytestring "\xc0\x80"]} +} 1 test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { - set x "\xe0" -} [testbytestring "\xc3\xa0"] + expr {"\xe0" eq [testbytestring "\xc3\xa0"]} +} 1 test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring { - set x "\u4e4e" -} [testbytestring "\xe4\xb9\x8e"] + expr {"\u4e4e" eq [testbytestring "\xe4\xb9\x8e"]} +} 1 test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { - format %c 0x110000 -} [testbytestring "\xef\xbf\xbd"] + expr {[format %c 0x110000] eq [testbytestring "\xef\xbf\xbd"]} +} 1 test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { - format %c -1 -} [testbytestring "\xef\xbf\xbd"] + expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]} +} 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" @@ -128,17 +128,17 @@ test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { } { } test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring { - set x \ua2 -} [testbytestring "\xc2\xa2"] + expr {"\ua2" eq [testbytestring "\xc2\xa2"]} +} 1 test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring { - set x \u4e21 -} [testbytestring "\xe4\xb8\xa1"] + expr {"\u4e21" eq [testbytestring "\xe4\xb8\xa1"]} +} 1 test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { - set x \u4e2k -} "[testbytestring \xd3\xa2]k" + expr {"\u4e2k" eq "[testbytestring \xd3\xa2]k"} +} 1 test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { - set x \u4e216 -} "[testbytestring \xe4\xb8\xa1]6" + expr {"\u4e216" eq "[testbytestring \xe4\xb8\xa1]6"} +} 1 proc bsCheck {char num} { global errNum test utf-10.$errNum {backslash substitution} { @@ -287,9 +287,11 @@ test utf-18.5 {Tcl_UniCharToTitle, no delta} { string totitle ! } ! -test utf-19.1 {TclUniCharLen} { +test utf-19.1 {TclUniCharLen} -body { list [regexp \\d abc456def foo] $foo -} {1 4} +} -cleanup { + unset -nocomplain foo +} -result {1 4} test utf-20.1 {TclUniCharNcmp} { } {} diff --git a/tests/var.test b/tests/var.test index 208b361..7ff394e 100644 --- a/tests/var.test +++ b/tests/var.test @@ -289,7 +289,7 @@ test var-3.11 {MakeUpvar, my var looks like array elem} -setup { } -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa foo(bar) -} -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} +} -result {bad variable name "foo(bar)": can't create a scalar variable that looks like an array element} test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { catch {unset a} @@ -865,6 +865,22 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup { }} array size x } -result 0 +test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup { + variable foo + variable lambda + unset -nocomplain lambda foo + array set foo {} + lappend lambda {} + lappend lambda [list array set [namespace which -variable foo] {a 1}] +} -body { + after 0 [list apply $lambda] + vwait [namespace which -variable foo] +} -cleanup { + unset -nocomplain lambda foo +} -result {} +test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body { + apply {{} {set name foo(bar); array set $name {a 1}}} +} -returnCodes error -match glob -result * test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { proc linenumber {} {dict get [info frame -1] line} diff --git a/tests/winFCmd.test b/tests/winFCmd.test index ab675d7..a808c82 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -1314,14 +1314,14 @@ test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body { file pathtype com4 } -result "absolute" test winFCmd-18.1.3 {Windows reserved path names} -constraints win -body { - file pathtype com5 -} -result "relative" + file pathtype com9 +} -result "absolute" test winFCmd-18.1.4 {Windows reserved path names} -constraints win -body { file pathtype lpt3 } -result "absolute" test winFCmd-18.1.5 {Windows reserved path names} -constraints win -body { - file pathtype lpt4 -} -result "relative" + file pathtype lpt9 +} -result "absolute" test winFCmd-18.1.6 {Windows reserved path names} -constraints win -body { file pathtype nul } -result "absolute" @@ -1423,6 +1423,11 @@ test winFCmd-19.8 {Windows extended path names} -constraints nt -setup { catch {file delete $tmpfile} } -result [list 0 {} [list "tcl[pid].tmp "]] +test winFCmd-19.9 {Windows devices path names} -constraints nt -body { + file normalize //./com1 +} -result //./com1 + + # This block of code used to occur after the "return" call, so I'm # commenting it out and assuming that this code is still under construction. #foreach source {tef ted tnf tnd "" nul com1} { diff --git a/unix/Makefile.in b/unix/Makefile.in index 0d9b9f0..311fdb2 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -294,7 +294,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \ - tclCompile.o tclConfig.o tclDate.o tclDictObj.o \ + tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \ tclEncoding.o tclEnsemble.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ @@ -407,6 +407,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclConfig.c \ $(GENERIC_DIR)/tclDate.c \ $(GENERIC_DIR)/tclDictObj.c \ + $(GENERIC_DIR)/tclDisassemble.c \ $(GENERIC_DIR)/tclEncoding.c \ $(GENERIC_DIR)/tclEnsemble.c \ $(GENERIC_DIR)/tclEnv.c \ @@ -1108,6 +1109,9 @@ tclConfig.o: $(GENERIC_DIR)/tclConfig.c tclDictObj.o: $(GENERIC_DIR)/tclDictObj.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDictObj.c +tclDisassemble.o: $(GENERIC_DIR)/tclDisassemble.c $(COMPILEHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDisassemble.c + tclEncoding.o: $(GENERIC_DIR)/tclEncoding.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEncoding.c @@ -1574,10 +1578,9 @@ tclUnixThrd.o: $(UNIX_DIR)/tclUnixThrd.c tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c +TCL_LOCATIONS=-DTCL_LIBRARY="\"${TCL_LIBRARY}\"" -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh - $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ - -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ - $(UNIX_DIR)/tclUnixInit.c + $(CC) -c $(CC_SWITCHES) $(TCL_LOCATIONS) $(UNIX_DIR)/tclUnixInit.c tclUnixCompat.o: $(UNIX_DIR)/tclUnixCompat.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixCompat.c diff --git a/unix/configure b/unix/configure index ec5e0ed..a9837d9 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".2" +TCL_PATCH_LEVEL=".3" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} @@ -7010,8 +7010,7 @@ fi LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' - TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a' - TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a' + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5 echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6 if test "${ac_cv_cygwin+set}" = set; then @@ -7677,7 +7676,14 @@ fi LDFLAGS="" ;; *) - SHLIB_CFLAGS="-fPIC" + case "$arch" in + alpha|sparc64) + SHLIB_CFLAGS="-fPIC" + ;; + *) + SHLIB_CFLAGS="-fpic" + ;; + esac SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" @@ -7744,8 +7750,7 @@ fi # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname=\$@" - TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$@" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" @@ -8983,7 +8988,7 @@ fi if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${TCL_SHLIB_LD_EXTRAS} ${SHLIB_LD_LIBS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' if test "${SHLIB_SUFFIX}" = ".dll"; then INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)"' diff --git a/unix/configure.in b/unix/configure.in index 85bd7ee..e44d554 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".2" +TCL_PATCH_LEVEL=".3" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} @@ -1,5 +1,5 @@ #!/bin/sh -# +# # ldAix ldCmd ldArg ldArg ... # # This shell script provides a wrapper for ld under AIX in order to @@ -40,8 +40,8 @@ rm -f lib.exp echo "#! $outputFile" >lib.exp /usr/ccs/bin/nm $nmopts $ofiles | sed -e '/:$/d' -e '/ U /d' -e 's/^\.//' -e 's/[ |].*//' | sort | uniq >>lib.exp -# If we're linking a .a file, then link all the objects together into a -# single file "shr.o" and then put that into the archive. Otherwise link +# If we're linking a .a file, then link all the objects together into a +# single file "shr.o" and then put that into the archive. Otherwise link # the object files directly into the .a file. noDotA=`echo $outputFile | sed -e '/\.a$/d'` diff --git a/unix/tcl.m4 b/unix/tcl.m4 index b23b9ac..277fe0b 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1217,8 +1217,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' - TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' - TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" AC_CACHE_CHECK(for Cygwin version of gcc, ac_cv_cygwin, AC_TRY_COMPILE([ @@ -1476,7 +1475,14 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LDFLAGS="" ;; *) - SHLIB_CFLAGS="-fPIC" + case "$arch" in + alpha|sparc64) + SHLIB_CFLAGS="-fPIC" + ;; + *) + SHLIB_CFLAGS="-fpic" + ;; + esac SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" @@ -1531,8 +1537,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname=\$[@]" - TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" + SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$[@]" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" @@ -2043,7 +2048,7 @@ dnl # preprocessing tests use only CPPFLAGS. AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [ LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${TCL_SHLIB_LD_EXTRAS} ${SHLIB_LD_LIBS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)"' DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" diff --git a/unix/tcl.spec b/unix/tcl.spec index 50aacc6..81f31da 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6.2 +Version: 8.6.3 Release: 2 License: BSD Group: Development/Languages @@ -30,7 +30,7 @@ CFLAGS="%optflags" ./configure \ --prefix=%{directory} \ --exec-prefix=%{directory} \ --libdir=%{directory}/%{_lib} -make +make %install cd unix diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 4e5d469..c99dcdc 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -794,7 +794,7 @@ TtySetOptionProc( * * Results: * A standard Tcl result. Also sets the supplied DString to the string - * value of the option(s) returned. Sets error message if needed + * value of the option(s) returned. Sets error message if needed * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- @@ -1203,7 +1203,7 @@ TtyParseMode( char parity; const char *bad = "bad value for -mode"; - i = sscanf(mode, "%d,%c,%d,%d%n", + i = sscanf(mode, "%d,%c,%d,%d%n", &ttyPtr->baud, &parity, &ttyPtr->data, @@ -1294,7 +1294,7 @@ TtyInit( || iostate.c_lflag != 0 || iostate.c_cflag & CREAD || iostate.c_cc[VMIN] != 1 - || iostate.c_cc[VTIME] != 0) + || iostate.c_cc[VTIME] != 0) { iostate.c_iflag = IGNBRK; iostate.c_oflag = 0; @@ -1363,6 +1363,11 @@ TclpOpenFileChannel( native = Tcl_FSGetNativePath(pathPtr); if (native == NULL) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", + TclGetString(pathPtr), "\": filename is invalid on this platform", + NULL); + } return NULL; } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 1617cba..520c8e5 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -768,7 +768,7 @@ TclpSetVariables( */ CFLocaleRef localeRef; - + if (CFLocaleCopyCurrent != NULL && CFLocaleGetIdentifier != NULL && (localeRef = CFLocaleCopyCurrent())) { CFStringRef locale = CFLocaleGetIdentifier(localeRef); diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 95bc8d1..8b26694 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -261,7 +261,7 @@ TclpTempFileName(void) * * On Unix, it works to load a shared object from a file of any name, so this * function is merely a thin wrapper around TclpTempFileName(). - * + * *---------------------------------------------------------------------------- */ @@ -969,7 +969,7 @@ PipeClose2Proc( pipePtr->outFile = NULL; } } - + /* * If half-closing, stop here. */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 96700ce..0188ea6 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -438,11 +438,11 @@ WaitForConnect( /* * Check if an async connect is running. If not return ok */ - + if (!(statePtr->flags & TCP_ASYNC_PENDING)) { return 0; } - + if (errorCodePtr == NULL || (statePtr->flags & TCP_NONBLOCKING)) { timeout = 0; } else { @@ -601,7 +601,7 @@ TcpCloseProc( * handlers are already deleted in the generic IO channel closing code * that called this function, so we do not have to delete them here. */ - + for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { if (fds->fd < 0) { continue; @@ -610,7 +610,7 @@ TcpCloseProc( if (close(fds->fd) < 0) { errorCode = errno; } - + } fds = statePtr->fds.next; while (fds != NULL) { @@ -823,7 +823,20 @@ TcpGetOptionProc( address peername; socklen_t size = sizeof(peername); - if (getpeername(statePtr->fds.fd, &peername.sa, &size) >= 0) { + if ( (statePtr->flags & TCP_ASYNC_CONNECT) ) { + /* + * In async connect output an empty string + */ + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringAppendElement(dsPtr, ""); + } else { + return TCL_OK; + } + } else if (getpeername(statePtr->fds.fd, &peername.sa, &size) >= 0) { + /* + * Peername fetch succeeded - output list + */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); @@ -863,11 +876,18 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); } - for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { - size = sizeof(sockname); - if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) { - found = 1; - TcpHostPortList(interp, dsPtr, sockname, size); + if ( (statePtr->flags & TCP_ASYNC_CONNECT) ) { + /* + * In async connect output an empty string + */ + found = 1; + } else { + for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { + size = sizeof(sockname); + if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) { + found = 1; + TcpHostPortList(interp, dsPtr, sockname, size); + } } } if (found) { @@ -954,7 +974,7 @@ TcpWatchProc( */ return; } - + if (statePtr->flags & TCP_ASYNC_PENDING) { /* Async sockets use a FileHandler internally while connecting, so we * need to cache this request until the connection has succeeded. */ @@ -1091,7 +1111,7 @@ TcpConnect( for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; statePtr->myaddr = statePtr->myaddr->ai_next) { int reuseaddr = 1; - + /* * No need to try combinations of local and remote addresses of * different families. @@ -1121,15 +1141,15 @@ TcpConnect( * Set the close-on-exec flag so that the socket will not get * inherited by child processes. */ - + fcntl(statePtr->fds.fd, F_SETFD, FD_CLOEXEC); - + /* * Set kernel space buffering */ - + TclSockMinimumBuffers(INT2PTR(statePtr->fds.fd), SOCKET_BUFSIZE); - + if (async) { ret = TclUnixSetBlockingMode(statePtr->fds.fd,TCL_MODE_NONBLOCKING); if (ret < 0) { @@ -1140,7 +1160,7 @@ TcpConnect( /* Gotta reset the error variable here, before we use it for the * first time in this iteration. */ error = 0; - + (void) setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr, @@ -1156,7 +1176,7 @@ TcpConnect( * will set up a file handler on the socket if she is interested * in being informed when the connect completes. */ - + ret = connect(statePtr->fds.fd, statePtr->addr->ai_addr, statePtr->addr->ai_addrlen); if (ret < 0) error = errno; @@ -1439,28 +1459,28 @@ Tcl_OpenTcpServer( } continue; } - + /* * Set the close-on-exec flag so that the socket will not get * inherited by child processes. */ - + fcntl(sock, F_SETFD, FD_CLOEXEC); - + /* * Set kernel space buffering */ - + TclSockMinimumBuffers(INT2PTR(sock), SOCKET_BUFSIZE); - + /* * Set up to reuse server addresses automatically and bind to the * specified port. */ - - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, + + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); - + /* * Make sure we use the same port number when opening two server * sockets for IPv4 and IPv6 on a random port. @@ -1489,7 +1509,7 @@ Tcl_OpenTcpServer( if (howfar < BIND) { howfar = BIND; my_errno = errno; - } + } close(sock); sock = -1; continue; @@ -1521,7 +1541,7 @@ Tcl_OpenTcpServer( /* * Allocate a new TcpState for this socket. */ - + statePtr = ckalloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->acceptProc = acceptProc; @@ -1536,12 +1556,12 @@ Tcl_OpenTcpServer( newfds->fd = sock; newfds->statePtr = statePtr; fds = newfds; - + /* * Set up the callback mechanism for accepting connections from new * clients. */ - + Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds); } @@ -1600,7 +1620,7 @@ TcpAccept( socklen_t len; /* For accept interface */ char channelName[SOCK_CHAN_LENGTH]; char host[NI_MAXHOST], port[NI_MAXSERV]; - + len = sizeof(addr); newsock = accept(fds->fd, &addr.sa, &len); if (newsock < 0) { diff --git a/unix/tclUnixThrd.h b/unix/tclUnixThrd.h index 6a73132..f03b530 100644 --- a/unix/tclUnixThrd.h +++ b/unix/tclUnixThrd.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ - + #ifndef _TCLUNIXTHRD #define _TCLUNIXTHRD diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 926e8f4..315bcf9 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -16,9 +16,6 @@ #include <mach/mach_time.h> #endif -#define TM_YEAR_BASE 1900 -#define IsLeapYear(x) (((x)%4 == 0) && ((x)%100 != 0 || (x)%400 == 0)) - /* * TclpGetDate is coded to return a pointer to a 'struct tm'. For thread * safety, this structure must be in thread-specific data. The 'tmKey' @@ -202,7 +199,7 @@ TclpWideClicksToNanoseconds( #ifdef MAC_OSX_TCL static mach_timebase_info_data_t tb; static uint64_t maxClicksForUInt64; - + if (!tb.denom) { mach_timebase_info(&tb); maxClicksForUInt64 = UINT64_MAX / tb.numer; diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 14b0d8d..55fe75f 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0.2 +TCLOO_VERSION=1.0.3 diff --git a/win/Makefile.in b/win/Makefile.in index 150f5b8..325b365 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -232,6 +232,7 @@ GENERIC_OBJS = \ tclConfig.$(OBJEXT) \ tclDate.$(OBJEXT) \ tclDictObj.$(OBJEXT) \ + tclDisassemble.$(OBJEXT) \ tclEncoding.$(OBJEXT) \ tclEnsemble.$(OBJEXT) \ tclEnv.$(OBJEXT) \ diff --git a/win/configure b/win/configure index cf2b201..b270648 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".2" +TCL_PATCH_LEVEL=".3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index aa47505..1bf901a 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".2" +TCL_PATCH_LEVEL=".3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/makefile.bc b/win/makefile.bc index a962bc6..f5196b6 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -207,6 +207,7 @@ TCLOBJS = \ $(TMPDIR)\tclConfig.obj \ $(TMPDIR)\tclDate.obj \ $(TMPDIR)\tclDictObj.obj \ + $(TMPDIR)\tclDisassemble.obj \ $(TMPDIR)\tclEncoding.obj \ $(TMPDIR)\tclEnsemble.obj \ $(TMPDIR)\tclEnv.obj \ @@ -587,3 +588,7 @@ clean: -@$(RM) $(TMPDIR)\*.exe -@$(RMDIR) $(OUTDIR) -@$(RMDIR) $(TMPDIR) + +# Local Variables: +# mode: makefile +# End: diff --git a/win/makefile.vc b/win/makefile.vc index e5f6c9b..8c65bd0 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -1,4 +1,4 @@ -#------------------------------------------------------------- -*- makefile -*- +#------------------------------------------------------------- # makefile.vc -- # # Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) @@ -281,6 +281,7 @@ COREOBJS = \ $(TMP_DIR)\tclConfig.obj \ $(TMP_DIR)\tclDate.obj \ $(TMP_DIR)\tclDictObj.obj \ + $(TMP_DIR)\tclDisassemble.obj \ $(TMP_DIR)\tclEncoding.obj \ $(TMP_DIR)\tclEnsemble.obj \ $(TMP_DIR)\tclEnv.obj \ @@ -1229,3 +1230,7 @@ realclean: hose hose: @echo Hosing $(OUT_DIR)\* ... @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) + +# Local Variables: +# mode: makefile +# End: diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in index 00a8790..75324b2 100644 --- a/win/tclConfig.sh.in +++ b/win/tclConfig.sh.in @@ -1,5 +1,5 @@ # tclConfig.sh -- -# +# # This shell script (for sh) is generated automatically by Tcl's # configure script. It will create shell variables for most of # the configuration options discovered by the configure script. diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 48acacb..cca0dab 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -843,6 +843,11 @@ TclpOpenFileChannel( nativeName = Tcl_FSGetNativePath(pathPtr); if (nativeName == NULL) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", + TclGetString(pathPtr), "\": filename is invalid on this platform", + NULL); + } return NULL; } @@ -966,7 +971,7 @@ TclpOpenFileChannel( switch (FileGetType(handle)) { case FILE_TYPE_SERIAL: /* - * Natively named serial ports "com1-9", "\\\\.\\comXX" are + * Natively named serial ports "com1-9", "\\\\.\\comXX" are * already done with the code above. * Here we handle all other serial port names. * @@ -1520,12 +1525,11 @@ FileGetType( * NativeIsComPort -- * * Determines if a path refers to a Windows serial port. - * A simple and efficient solution is to use a "name hint" to detect - * COM ports by their filename instead of resorting to a syscall + * A simple and efficient solution is to use a "name hint" to detect + * COM ports by their filename instead of resorting to a syscall * to detect serialness after the fact. * The following patterns cover common serial port names: - * COM[1-9]:? - * //./COM[0-9]+ + * COM[1-9] * \\.\COM[0-9]+ * * Results: @@ -1545,33 +1549,26 @@ NativeIsComPort( * 1. Look for com[1-9]:? */ - if ( (len >= 4) && (len <= 5) - && (_wcsnicmp(p, L"com", 3) == 0) ) { + if ( (len == 4) && (_wcsnicmp(p, L"com", 3) == 0) ) { /* - * The 4th character must be a digit 1..9 optionally followed by a ":" + * The 4th character must be a digit 1..9 */ - + if ( (p[3] < L'1') || (p[3] > L'9') ) { return 0; } - if ( (len == 5) && (p[4] != L':') ) { - return 0; - } return 1; } - + /* - * 2. Look for //./com[0-9]+ or \\.\com[0-9]+ + * 2. Look for \\.\com[0-9]+ */ - - if ( (len >= 8) && ( - (_wcsnicmp(p, L"//./com", 7) == 0) - || (_wcsnicmp(p, L"\\\\.\\com", 7) == 0) ) ) - { + + if ((len >= 8) && (_wcsnicmp(p, L"\\\\.\\com", 7) == 0)) { /* * Charaters 8..end must be a digits 0..9 */ - + for ( i=7; i<len; i++ ) { if ( (p[i] < '0') || (p[i] > '9') ) { return 0; diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 6630083..63150ef 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -761,7 +761,7 @@ ConsoleInputProc( * by the caller. In practice this is harmless, since all writes * are into ChannelBuffers, and those have padding, but still * ought to remove this, unless some Windows wizard can give - * a reason not to. + * a reason not to. */ buf[count] = '\0'; return count; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index fe84a26..d6ca348 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1241,9 +1241,9 @@ WinIsReserved( if ((path[0] == 'c' || path[0] == 'C') && (path[1] == 'o' || path[1] == 'O')) { if ((path[2] == 'm' || path[2] == 'M') - && path[3] >= '1' && path[3] <= '4') { + && path[3] >= '1' && path[3] <= '9') { /* - * May have match for 'com[1-4]:?', which is a serial port. + * May have match for 'com[1-9]:?', which is a serial port. */ if (path[4] == '\0') { @@ -1262,9 +1262,9 @@ WinIsReserved( } else if ((path[0] == 'l' || path[0] == 'L') && (path[1] == 'p' || path[1] == 'P') && (path[2] == 't' || path[2] == 'T')) { - if (path[3] >= '1' && path[3] <= '3') { + if (path[3] >= '1' && path[3] <= '9') { /* - * May have match for 'lpt[1-3]:?' + * May have match for 'lpt[1-9]:?' */ if (path[4] == '\0') { @@ -2933,18 +2933,22 @@ TclNativeCreateNativeRep( /* String contains NUL-bytes. This is invalid. */ return 0; } - /* Let MultiByteToWideChar check for other invalid sequences, like - * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */ - len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0); - if (len==0) { - return 0; + /* For a reserved device, strip a possible postfix ':' */ + len = WinIsReserved(str); + if (len == 0) { + /* Let MultiByteToWideChar check for other invalid sequences, like + * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */ + len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0); + if (len==0) { + return 0; + } } /* Overallocate 6 chars, making some room for extended paths */ wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) ); if (nativePathPtr==0) { return 0; } - MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len); + MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1); /* ** If path starts with "//?/" or "\\?\" (extended path), translate ** any slashes to backslashes but leave the '?' intact diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 652cd06..ca6b2bf 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -433,17 +433,17 @@ typedef DWORD_PTR * PDWORD_PTR; * EDEADLK as the same value, which confuses Tcl_ErrnoId(). */ -#if defined(_MSC_VER) || defined(__MINGW32__) +#if defined(_MSC_VER) || defined(__MSVCRT__) # define environ _environ # if defined(_MSC_VER) && (_MSC_VER < 1600) # define hypot _hypot # endif # define exception _exception # undef EDEADLOCK -# if defined(__MINGW32__) && !defined(__MSVCRT__) +# if defined(_MSC_VER) && (_MSC_VER >= 1700) # define timezone _timezone # endif -#endif /* _MSC_VER || __MINGW32__ */ +#endif /* _MSC_VER || __MSVCRT__ */ /* * Borland's timezone and environ functions. @@ -505,7 +505,7 @@ typedef DWORD_PTR * PDWORD_PTR; * Msvcrt's putenv() copies the string rather than takes ownership of it. */ -#if defined(_MSC_VER) || defined(__MINGW32__) +#if defined(_MSC_VER) || defined(__MSVCRT__) # define HAVE_PUTENV_THAT_COPIES 1 #endif diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 6487fe4..0730a46 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1415,7 +1415,7 @@ SerialWriterThread( * Opens or Reopens the serial port with the OVERLAPPED FLAG set * * Results: - * Returns the new handle, or INVALID_HANDLE_VALUE. + * Returns the new handle, or INVALID_HANDLE_VALUE. * If an existing channel is specified it is closed and reopened. * * Side effects: diff --git a/win/tclWinSock.c b/win/tclWinSock.c index f343f82..2c58224 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -596,7 +596,7 @@ WaitForConnect( /* * Check if an async connect is running. If not return ok */ - + if (!(statePtr->flags & TCP_ASYNC_CONNECT)) { return 0; } @@ -616,7 +616,7 @@ WaitForConnect( /* get statePtr lock */ tsdPtr = TclThreadDataKeyGet(&dataKey); WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - + /* Check for connect event */ if (statePtr->readyEvents & FD_CONNECT) { @@ -1250,7 +1250,7 @@ TcpGetOptionProc( return TCL_ERROR; } - /* + /* * Go one step in async connect * If any error is thrown save it as backround error to report eventually below */ @@ -1337,7 +1337,20 @@ TcpGetOptionProc( address peername; socklen_t size = sizeof(peername); - if (getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { + if ( (statePtr->flags & TCP_ASYNC_PENDING) ) { + /* + * In async connect output an empty string + */ + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringAppendElement(dsPtr, ""); + } else { + return TCL_OK; + } + } else if ( getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { + /* + * Peername fetch succeeded - output list + */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); @@ -1386,49 +1399,55 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); } - for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { - sock = fds->fd; - size = sizeof(sockname); - if (getsockname(sock, &(sockname.sa), &size) >= 0) { - int flags = reverseDNS; - - found = 1; - getnameinfo(&sockname.sa, size, host, sizeof(host), - NULL, 0, NI_NUMERICHOST); - Tcl_DStringAppendElement(dsPtr, host); - - /* - * We don't want to resolve INADDR_ANY and sin6addr_any; they - * can sometimes cause problems (and never have a name). - */ - flags |= NI_NUMERICSERV; - if (sockname.sa.sa_family == AF_INET) { - if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { - flags |= NI_NUMERICHOST; - } - } else if (sockname.sa.sa_family == AF_INET6) { - if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr, - &in6addr_any)) || - (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) - && sockname.sa6.sin6_addr.s6_addr[12] == 0 - && sockname.sa6.sin6_addr.s6_addr[13] == 0 - && sockname.sa6.sin6_addr.s6_addr[14] == 0 - && sockname.sa6.sin6_addr.s6_addr[15] == 0)) { - flags |= NI_NUMERICHOST; + if ( (statePtr->flags & TCP_ASYNC_PENDING ) ) { + /* + * In async connect output an empty string + */ + found = 1; + } else { + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + sock = fds->fd; + size = sizeof(sockname); + if (getsockname(sock, &(sockname.sa), &size) >= 0) { + int flags = reverseDNS; + + found = 1; + getnameinfo(&sockname.sa, size, host, sizeof(host), + NULL, 0, NI_NUMERICHOST); + Tcl_DStringAppendElement(dsPtr, host); + + /* + * We don't want to resolve INADDR_ANY and sin6addr_any; they + * can sometimes cause problems (and never have a name). + */ + flags |= NI_NUMERICSERV; + if (sockname.sa.sa_family == AF_INET) { + if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { + flags |= NI_NUMERICHOST; + } + } else if (sockname.sa.sa_family == AF_INET6) { + if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr, + &in6addr_any)) || + (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) + && sockname.sa6.sin6_addr.s6_addr[12] == 0 + && sockname.sa6.sin6_addr.s6_addr[13] == 0 + && sockname.sa6.sin6_addr.s6_addr[14] == 0 + && sockname.sa6.sin6_addr.s6_addr[15] == 0)) { + flags |= NI_NUMERICHOST; + } } + getnameinfo(&sockname.sa, size, host, sizeof(host), + port, sizeof(port), flags); + Tcl_DStringAppendElement(dsPtr, host); + Tcl_DStringAppendElement(dsPtr, port); } - getnameinfo(&sockname.sa, size, host, sizeof(host), - port, sizeof(port), flags); - Tcl_DStringAppendElement(dsPtr, host); - Tcl_DStringAppendElement(dsPtr, port); } } if (found) { - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { + if (len) { return TCL_OK; } + Tcl_DStringEndSublist(dsPtr); } else { if (interp) { TclWinConvertError((DWORD) WSAGetLastError()); @@ -1628,14 +1647,14 @@ TcpConnect( /* We were called by the event procedure and continue our loop */ int async_callback = statePtr->flags & TCP_ASYNC_PENDING; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - + if (async_callback) { goto reenter; } - + for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; statePtr->addr = statePtr->addr->ai_next) { - + for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; statePtr->myaddr = statePtr->myaddr->ai_next) { @@ -1651,7 +1670,7 @@ TcpConnect( /* * Close the socket if it is still open from the last unsuccessful * iteration. - */ + */ if (statePtr->sockets->fd != INVALID_SOCKET) { closesocket(statePtr->sockets->fd); } @@ -1664,9 +1683,9 @@ TcpConnect( */ statePtr->notifierConnectError = 0; Tcl_SetErrno(0); - + statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0); - + /* Free list lock */ SetEvent(tsdPtr->socketListLock); @@ -1735,7 +1754,7 @@ TcpConnect( * thread. */ statePtr->selectEvents |= FD_CONNECT; - + /* * Free list lock */ @@ -1749,7 +1768,7 @@ TcpConnect( /* * Attempt to connect to the remote socket. */ - + connect(statePtr->sockets->fd, statePtr->addr->ai_addr, statePtr->addr->ai_addrlen); @@ -1790,7 +1809,7 @@ TcpConnect( * the FD_CONNECT asyncroneously */ tsdPtr->pendingTcpState = NULL; - + if (Tcl_GetErrno() == 0) { goto out; } @@ -1816,12 +1835,12 @@ out: * Set up the select mask for read/write events. */ statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; - + /* * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. */ - + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) statePtr); } else { @@ -2073,20 +2092,20 @@ Tcl_OpenTcpServer( TclWinConvertError((DWORD) WSAGetLastError()); continue; } - + /* * Win-NT has a misfeature that sockets are inherited in child * processes by default. Turn off the inherit bit. */ - + SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); - + /* * Set kernel space buffering */ - + TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); - + /* * Make sure we use the same port when opening two server sockets * for IPv4 and IPv6. @@ -2094,12 +2113,12 @@ Tcl_OpenTcpServer( * As sockaddr_in6 uses the same offset and size for the port * member as sockaddr_in, we can handle both through the IPv4 API. */ - + if (port == 0 && chosenport != 0) { ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = htons(chosenport); } - + /* * Bind to the specified port. Note that we must not call * setsockopt with SO_REUSEADDR because Microsoft allows addresses @@ -2109,7 +2128,7 @@ Tcl_OpenTcpServer( * set into nonblocking mode. If there is trouble, this is one * place to look for bugs. */ - + if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); @@ -2119,29 +2138,29 @@ Tcl_OpenTcpServer( if (port == 0 && chosenport == 0) { address sockname; socklen_t namelen = sizeof(sockname); - + /* * Synchronize port numbers when binding to port 0 of multiple * addresses. */ - + if (getsockname(sock, &sockname.sa, &namelen) >= 0) { chosenport = ntohs(sockname.sa4.sin_port); } } - + /* * Set the maximum number of pending connect requests to the max * value allowed on each platform (Win32 and Win32s may be * different, and there may be differences between TCP/IP stacks). */ - + if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); closesocket(sock); continue; } - + if (statePtr == NULL) { /* * Add this socket to the global list of sockets. @@ -2167,9 +2186,9 @@ error: /* * Set up the select mask for connection request events. */ - + statePtr->selectEvents = FD_ACCEPT; - + /* * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. @@ -2633,7 +2652,7 @@ SocketEventProc( WaitForConnect(statePtr,NULL); } else { - + /* * No async connect reenter pending. Just clear event. */ @@ -2662,7 +2681,7 @@ SocketEventProc( * network stack conditions that can result in FD_ACCEPT but a subsequent * failure on accept() by the time we get around to it. * Access to sockets (acceptEventCount, readyEvents) in socketList - * is still protected by the lock (prevents reintroduction of + * is still protected by the lock (prevents reintroduction of * SF Tcl Bug 3056775. */ @@ -2694,9 +2713,9 @@ SocketEventProc( return 1; } - /* Loop terminated with no sockets accepted; clear the ready mask so - * we can detect the next connection request. Note that connection - * requests are level triggered, so if there is a request already + /* Loop terminated with no sockets accepted; clear the ready mask so + * we can detect the next connection request. Note that connection + * requests are level triggered, so if there is a request already * pending, a new event will be generated. */ statePtr->acceptEventCount = 0; @@ -2739,7 +2758,7 @@ SocketEventProc( if ( statePtr->flags & TCP_ASYNC_FAILED ) { mask |= TCL_READABLE; - + } else { fd_set readFds; struct timeval timeout; @@ -2777,11 +2796,11 @@ SocketEventProc( if (events & FD_WRITE) { mask |= TCL_WRITABLE; } - + /* * Call registered event procedures */ - + if (mask) { Tcl_NotifyChannel(statePtr->channel, mask); } @@ -2793,7 +2812,7 @@ SocketEventProc( * * AddSocketInfoFd -- * - * This function adds a SOCKET file descriptor to the 'sockets' linked + * This function adds a SOCKET file descriptor to the 'sockets' linked * list of a TcpState structure. * * Results: @@ -2807,7 +2826,7 @@ SocketEventProc( static void AddSocketInfoFd( - TcpState *statePtr, + TcpState *statePtr, SOCKET socket) { TcpFdList *fds = statePtr->sockets; @@ -2821,7 +2840,7 @@ AddSocketInfoFd( while ( fds->next != NULL ) { fds = fds->next; } - + fds->next = ckalloc(sizeof(TcpFdList)); fds = fds->next; } @@ -2832,7 +2851,7 @@ AddSocketInfoFd( fds->next = NULL; } - + /* *---------------------------------------------------------------------- * @@ -2916,7 +2935,7 @@ WaitForSocketEvent( /* get statePtr lock */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - + /* Check if event occured */ event_found = (statePtr->readyEvents & events); @@ -2927,7 +2946,7 @@ WaitForSocketEvent( if (event_found) { break; } - + /* Exit loop if event did not occur but this is a non-blocking channel */ if (statePtr->flags & TCP_NONBLOCKING) { *errorCodePtr = EWOULDBLOCK; @@ -3294,11 +3313,11 @@ TcpThreadActionProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); statePtr->nextPtr = tsdPtr->socketList; tsdPtr->socketList = statePtr; - + if (statePtr == tsdPtr->pendingTcpState) { tsdPtr->pendingTcpState = NULL; } - + SetEvent(tsdPtr->socketListLock); notifyCmd = SELECT; diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 14b0d8d..55fe75f 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0.2 +TCLOO_VERSION=1.0.3 diff --git a/win/tclsh.exe.manifest.in b/win/tclsh.exe.manifest.in index b7c4381..8b06fce 100644 --- a/win/tclsh.exe.manifest.in +++ b/win/tclsh.exe.manifest.in @@ -20,6 +20,8 @@ </trustInfo> <compatibility xmlns="urn:schemas-microsoft-com:compatibility.v1"> <application> + <!-- Windows 10 --> + <supportedOS Id="{8e0f7a12-bfb3-4fe8-b9a5-48fd50a15a9a}"/> <!-- Windows 8.1 --> <supportedOS Id="{1f676c76-80e1-4239-95bb-83d0f6d0da78}"/> <!-- Windows 8 --> |