From ed18777278424ffe80fe995e2191f6bf6231fa4f Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 1 Nov 2012 20:40:55 +0000 Subject: Working towards a BCCed [next]. This version almost works, except for a problem with restoring the context namespace upon return (which produces very strange results!) --- generic/tclCompCmds.c | 29 +++++++++++++++++++++++++ generic/tclCompile.c | 4 ++++ generic/tclCompile.h | 5 ++++- generic/tclExecute.c | 59 +++++++++++++++++++++++++++++++++++++++++++++++++-- generic/tclInt.h | 4 ++++ generic/tclOO.c | 9 ++++---- generic/tclOOBasic.c | 12 +++++------ 7 files changed, 108 insertions(+), 14 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5beb7bd..96bb9a4 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -5535,6 +5535,35 @@ IndexTailVarIfKnown( return localIndex; } +/* + * Compilations of commands relating to TclOO. + */ + +int +TclCompileObjectNextCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + int i; + + if (parsePtr->numWords > 255) { + return TCL_ERROR; + } + + for (i=0 ; inumWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr); + return TCL_OK; +} + int TclCompileObjectSelfCmd( Tcl_Interp *interp, /* Used for error reporting. */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ee8511c..188b3f8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -484,9 +484,13 @@ InstructionDesc const tclInstructionTable[] = { * qualified version, or produces the empty string if no such command * exists. Never generates errors. * Stack: ... cmdName => ... fullCmdName */ + {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, /* Push the identity of the current TclOO object (i.e., the name of * its current public access command) on the stack. */ + {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Push the identity of the current TclOO object (i.e., the name of + * its current public access command) on the stack. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 08d59fd..e623e87 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -698,10 +698,13 @@ typedef struct ByteCode { #define INST_INFO_LEVEL_NUM 150 #define INST_INFO_LEVEL_ARGS 151 #define INST_RESOLVE_COMMAND 152 + +/* For compilation relating to TclOO */ #define INST_TCLOO_SELF 153 +#define INST_TCLOO_NEXT 154 /* The last opcode */ -#define LAST_INST_OPCODE 153 +#define LAST_INST_OPCODE 154 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1e24cb3..f6b99bf 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4208,10 +4208,18 @@ TEBCresume( TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); } - case INST_TCLOO_SELF: { - CallFrame *framePtr = iPtr->varFramePtr; + + /* + * ----------------------------------------------------------------- + * Start of TclOO support instructions. + */ + + { + CallFrame *framePtr; CallContext *contextPtr; + case INST_TCLOO_SELF: + framePtr = iPtr->varFramePtr; if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE(("=> ERROR: no TclOO call context\n")); @@ -4230,9 +4238,56 @@ TEBCresume( objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + + case INST_TCLOO_NEXT: + opnd = TclGetUInt1AtPtr(pc+1); + framePtr = iPtr->varFramePtr; + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE(("%d => ERROR: no TclOO call context\n", opnd)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "next may only be called from inside a method", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + goto gotError; + } + contextPtr = framePtr->clientData; + + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } + + pcAdjustment = 2; + cleanup = opnd; + DECACHE_STACK_INFO(); + + /* + * BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG + * + * Bug somewhere near here. The iPtr->varFramePtr must be updated as + * below, but TclOONextRestoreFrame (in tclOOBasic.c) seems to be + * unable to restore the frame upon return... + * + * If TclOONextRestoreFrame is wrong for use here (and it might be!) + * it should be copied to this file and adjusted afterwards. It is + * *correct* for its other uses. + */ + + iPtr->varFramePtr = framePtr->callerVarPtr; + TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, + NULL, NULL, NULL); + pc += pcAdjustment; + TEBC_YIELD(); + return TclNRObjectContextInvokeNext(interp, + (Tcl_ObjectContext) contextPtr, opnd, &OBJ_AT_DEPTH(opnd-1), 1); } /* + * End of TclOO support instructions. * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 1fffa1f..549ada9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2804,6 +2804,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_NRPostProc TclOONextRestoreFrame; MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp, struct NRE_callback *tailcallPtr); @@ -3620,6 +3621,9 @@ MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclOO.c b/generic/tclOO.c index d6d2d6a..68ed766 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -437,10 +437,11 @@ InitFoundation( * ensemble. */ - Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL, - NULL); - Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd, - NULL, NULL); + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", + NULL, TclOONextObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextCmd; + Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", + NULL, TclOONextToObjCmd, NULL, NULL); cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectSelfCmd; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 0676618..cd57063 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -25,8 +25,6 @@ static int FinalizeConstruction(ClientData data[], Tcl_Interp *interp, int result); static int FinalizeEval(ClientData data[], Tcl_Interp *interp, int result); -static int RestoreFrame(ClientData data[], - Tcl_Interp *interp, int result); /* * ---------------------------------------------------------------------- @@ -805,7 +803,7 @@ TclOONextObjCmd( * that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL); + TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, NULL,NULL,NULL); iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } @@ -874,8 +872,8 @@ TclOONextToObjCmd( * context. Note that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr, - INT2PTR(contextPtr->index), NULL); + TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, + contextPtr, INT2PTR(contextPtr->index), NULL); contextPtr->index = i-1; iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, @@ -904,8 +902,8 @@ TclOONextToObjCmd( return TCL_ERROR; } -static int -RestoreFrame( +int +TclOONextRestoreFrame( ClientData data[], Tcl_Interp *interp, int result) -- cgit v0.12 From 6d14b815b2889457c7f12b3c881356aa5c61baa6 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Nov 2012 16:50:06 +0000 Subject: Work on compilation of [string is]. Hit some problem edge cases with differences in strictness of edge cases that will force a rethink ([string is boolean] is significantly more strict than Tcl_GetBooleanFromObj). --- generic/tclCmdMZ.c | 2 +- generic/tclCompCmdsSZ.c | 190 ++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 + 3 files changed, 194 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index de32fce..0526325 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3306,7 +3306,7 @@ TclInitStringCmd( {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, - {"is", StringIsCmd, NULL, NULL, NULL, 0}, + {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, NULL, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 57cb992..b9309ec 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -451,6 +451,196 @@ TclCompileStringIndexCmd( /* *---------------------------------------------------------------------- * + * TclCompileStringIsCmd -- + * + * Procedure called to compile the simplest and most common form of the + * "string is" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "string is" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringIsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + int numWords = parsePtr->numWords; + enum IsType { + TypeBool, TypeBoolFalse, TypeBoolTrue, + TypeFloat, + TypeInteger, TypeNarrowInt, TypeWideInt, + TypeList /*, TypeDict */ + }; + enum IsType t; + JumpFixup jumpFixup; + int start, range; + int allowEmpty = 0; + + if (numWords < 2 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } +#define GotLiteral(tokenPtr,word) \ + ((tokenPtr)[1].size > 1 && (tokenPtr)[1].start[0] == word[0] && \ + strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) + + if (GotLiteral(tokenPtr, "boolean")) { + t = TypeBool; + } else if (GotLiteral(tokenPtr, "double")) { + t = TypeFloat; + } else if (GotLiteral(tokenPtr, "entier")) { + t = TypeInteger; + } else if (GotLiteral(tokenPtr, "false")) { + t = TypeBoolFalse; + } else if (GotLiteral(tokenPtr, "integer")) { + t = TypeNarrowInt; + return TCL_ERROR; // Not yet implemented + } else if (GotLiteral(tokenPtr, "list")) { + t = TypeList; + } else if (GotLiteral(tokenPtr, "true")) { + t = TypeBoolTrue; + } else if (GotLiteral(tokenPtr, "wideinteger")) { + t = TypeWideInt; + return TCL_ERROR; // Not yet implemented + } else { + /* + * We don't handle character class checks in bytecode currently. + */ + + return TCL_ERROR; + } + if (numWords != 3 && numWords != 4) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + if (numWords == 3) { + allowEmpty = (t != TypeList); + } else { + if (!GotLiteral(tokenPtr, "-strict")) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + } +#undef GotLiteral + + /* + * Push the word to check. + */ + + CompileWord(envPtr, tokenPtr, interp, numWords-1); + + /* + * Next, do the type check. First, we push a catch range; most of the + * type-check operations throw an exception on failure. + */ + + range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + start = 0; + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + ExceptionRangeStarts(envPtr, range); + + /* + * Issue the type-check itself for the specific type. + */ + + switch (t) { + case TypeBool: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LNOT, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeBoolFalse: + TclEmitOpcode( INST_DUP, envPtr); + start = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + break; + case TypeBoolTrue: + TclEmitOpcode( INST_DUP, envPtr); + start = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + break; + case TypeFloat: + /* + * Careful! Preserve behavior of NaN which is a double (that is, true + * for the purposes of a type check) but most math ops fail on it. The + * key is that it is not == to itself (and is the only value which + * this is true for). + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_NEQ, envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 5, envPtr); + + /* + * Type check for all other double values. + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_UMINUS, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeInteger: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_BITNOT, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeNarrowInt: + Tcl_Panic("not yet implemented"); + case TypeWideInt: + Tcl_Panic("not yet implemented"); + case TypeList: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + } + + /* + * Based on whether the exception was thrown (or conditional branch taken, + * in the case of true/false checks), push the correct boolean value. This + * is also where we deal with what happens with empty values in non-strict + * mode. + */ + + ExceptionRangeEnds(envPtr, range); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + ExceptionRangeTarget(envPtr, range, catchOffset); + if (start != 0) { + TclStoreInt1AtPtr(CurrentOffset(envPtr) - start, + envPtr->codeStart + start + 1); + } + TclEmitOpcode( INST_END_CATCH, envPtr); + if (allowEmpty) { + PushLiteral(envPtr, "", 0); + TclEmitOpcode( INST_STR_EQ, envPtr); + } else { + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "0", 1); + } + TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileStringMatchCmd -- * * Procedure called to compile the simplest and most common form of the diff --git a/generic/tclInt.h b/generic/tclInt.h index 1fffa1f..e513a6e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3647,6 +3647,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 2de2d8678ff1f078e5d5b0cbf3d9e7640037e2ad Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Nov 2012 20:39:10 +0000 Subject: reorder to preserve main BC development branch sequence better --- generic/tclCompile.c | 10 +++++----- generic/tclCompile.h | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7036f6a..c390971 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -488,17 +488,17 @@ InstructionDesc const tclInstructionTable[] = { {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, /* Push the identity of the current TclOO object (i.e., the name of * its current public access command) on the stack. */ - {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Push the identity of the current TclOO object (i.e., the name of - * its current public access command) on the stack. */ - {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, + {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, /* Push the class of the TclOO object named at the top of the stack * onto the stack. * Stack: ... object => ... class */ - {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, + {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, /* Push the namespace of the TclOO object named at the top of the * stack onto the stack. * Stack: ... object => ... namespace */ + {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Push the identity of the current TclOO object (i.e., the name of + * its current public access command) on the stack. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cab517d..c860307 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -701,9 +701,9 @@ typedef struct ByteCode { /* For compilation relating to TclOO */ #define INST_TCLOO_SELF 153 -#define INST_TCLOO_NEXT 154 -#define INST_TCLOO_CLASS 155 -#define INST_TCLOO_NS 156 +#define INST_TCLOO_CLASS 154 +#define INST_TCLOO_NS 155 +#define INST_TCLOO_NEXT 156 /* The last opcode */ #define LAST_INST_OPCODE 156 -- cgit v0.12 From 93595c68aa99a9fc2af1b6033358c5b159f04ae8 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Sep 2013 03:00:06 +0000 Subject: First attempt at [string trim] compilation. --- generic/tclAssembly.c | 5 +- generic/tclCmdMZ.c | 8 +-- generic/tclCompCmdsSZ.c | 135 ++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 11 ++++ generic/tclCompile.h | 6 ++- generic/tclExecute.c | 33 ++++++++++++ generic/tclInt.h | 9 ++++ 7 files changed, 202 insertions(+), 5 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 946c729..659f483 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -462,6 +462,8 @@ static const TalInstDesc TalInstructionTable[] = { {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, + {"strtrimLeft", ASSEM_1BYTE, INST_STRTRIM_LEFT, 2, 1}, + {"strtrimRight", ASSEM_1BYTE, INST_STRTRIM_RIGHT, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, @@ -502,7 +504,8 @@ static const unsigned char NonThrowingByteCodes[] = { INST_COROUTINE_NAME, /* 149 */ INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ - INST_RESOLVE_COMMAND /* 154 */ + INST_RESOLVE_COMMAND, /* 154 */ + INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166,167 */ }; /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5087fbb..2b5e995 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -35,6 +35,8 @@ static int UniCharIsHexDigit(int character); /* * Default set of characters to trim in [string trim] and friends. This is a * UTF-8 literal string containing all Unicode space characters [TIP #413] + * + * Synch with tclCompCmdsSZ.c */ #define DEFAULT_TRIM_SET \ @@ -3342,9 +3344,9 @@ TclInitStringCmd( {"tolower", StringLowerCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"toupper", StringUpperCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"totitle", StringTitleCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"trim", StringTrimCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"trimleft", StringTrimLCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"trimright", StringTrimRCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0}, + {"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0}, + {"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0}, {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 44cb66e..0177b2d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -640,6 +640,141 @@ TclCompileStringRangeCmd( OP( STR_RANGE); return TCL_OK; } + +/* + * Synch with tclCmdMZ.c + */ + +#define DEFAULT_TRIM_SET \ + "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ + "\xc0\x80" /* nul (U+0000) */\ + "\xc2\x85" /* next line (U+0085) */\ + "\xc2\xa0" /* non-breaking space (U+00a0) */\ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ + "\xe2\x80\x80" /* en quad (U+2000) */\ + "\xe2\x80\x81" /* em quad (U+2001) */\ + "\xe2\x80\x82" /* en space (U+2002) */\ + "\xe2\x80\x83" /* em space (U+2003) */\ + "\xe2\x80\x84" /* three-per-em space (U+2004) */\ + "\xe2\x80\x85" /* four-per-em space (U+2005) */\ + "\xe2\x80\x86" /* six-per-em space (U+2006) */\ + "\xe2\x80\x87" /* figure space (U+2007) */\ + "\xe2\x80\x88" /* punctuation space (U+2008) */\ + "\xe2\x80\x89" /* thin space (U+2009) */\ + "\xe2\x80\x8a" /* hair space (U+200a) */\ + "\xe2\x80\x8b" /* zero width space (U+200b) */\ + "\xe2\x80\xa8" /* line separator (U+2028) */\ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ + "\xe2\x81\xa0" /* word joiner (U+2060) */\ + "\xe3\x80\x80" /* ideographic space (U+3000) */\ + "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ + +int +TclCompileStringTrimLCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + } else { + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + } + OP( STRTRIM_LEFT); + return TCL_OK; +} + +int +TclCompileStringTrimRCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + } else { + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + } + OP( STRTRIM_RIGHT); + return TCL_OK; +} + +int +TclCompileStringTrimCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + TclNewObj(objPtr); + if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + int len; + const char *p = Tcl_GetStringFromObj(objPtr, &len); + + PushLiteral(envPtr, p, len); + OP( STRTRIM_LEFT); + PushLiteral(envPtr, p, len); + OP( STRTRIM_RIGHT); + } else { + CompileWord(envPtr, tokenPtr, interp, 2); + OP4( REVERSE, 2); + OP4( OVER, 1); + OP( STRTRIM_LEFT); + OP4( REVERSE, 2); + OP( STRTRIM_RIGHT); + } + TclDecrRefCount(objPtr); + } else { + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + OP( STRTRIM_LEFT); + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + OP( STRTRIM_RIGHT); + } + return TCL_OK; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d15ef3a..cdedbda 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -545,6 +545,17 @@ InstructionDesc const tclInstructionTable[] = { /* Drops an element from the auxiliary stack, popping stack elements * until the matching stack depth is reached. */ + {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimleft] core: removes the characters (designated by the + * value at the top of the stack) from the left of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + {"strtrimRight", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimright] core: removes the characters (designated by the + * value at the top of the stack) from the right of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5660055..08eb393 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -768,8 +768,12 @@ typedef struct ByteCode { #define INST_EXPAND_DROP 165 +/* For compilation of [string trim] and related */ +#define INST_STRTRIM_LEFT 166 +#define INST_STRTRIM_RIGHT 167 + /* The last opcode */ -#define LAST_INST_OPCODE 165 +#define LAST_INST_OPCODE 167 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0ca393b..b4785bf 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5252,6 +5252,39 @@ TEBCresume( objResultPtr = TCONST(match); NEXT_INST_F(0, 2, 1); + { + const char *string1, *string2; + + case INST_STRTRIM_LEFT: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + match = TclTrimLeft(string1, length, string2, length2); + if (match == 0) { + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), + valuePtr); + NEXT_INST_F(1, 1, 0); + } else { + objResultPtr = Tcl_NewStringObj(string1+match, length-match); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), + objResultPtr); + NEXT_INST_F(1, 2, 1); + } + case INST_STRTRIM_RIGHT: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + match = TclTrimRight(string1, length, string2, length2); + if (match == 0) { + NEXT_INST_F(1, 1, 0); + } else { + objResultPtr = Tcl_NewStringObj(string1, length-match); + NEXT_INST_F(1, 2, 1); + } + } + case INST_REGEXP: cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ diff --git a/generic/tclInt.h b/generic/tclInt.h index feea6dd..2312734 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3614,6 +3614,15 @@ MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimLCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimRCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 066dd2cb10e47966daf012c11aeee963f7494150 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 08:46:29 +0000 Subject: Expand subset of lreplace functionality that is compiled. --- generic/tclCompCmdsGR.c | 159 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 142 insertions(+), 17 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 43ea3d3..e695068 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1430,9 +1430,9 @@ TclCompileLreplaceCmd( Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ Tcl_Obj *tmpObj; - int idx1, idx2, result, guaranteedDropAll = 0; + int idx1, idx2, result, i, offset; - if (parsePtr->numWords != 4) { + if (parsePtr->numWords < 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1492,38 +1492,163 @@ TclCompileLreplaceCmd( } /* - * Sanity check: can only issue when we're removing a range at one or - * other end of the list. If we're at one end or the other, convert the - * indices into the equivalent for an [lrange]. + * Work out what this [lreplace] is actually doing. */ + tmpObj = NULL; + CompileWord(envPtr, listTokenPtr, interp, 1); + if (parsePtr->numWords == 4) { + if (idx1 == 0) { + if (idx2 == -2) { + goto dropAll; + } + idx1 = idx2 + 1; + idx2 = -2; + goto dropEnd; + } else if (idx2 == -2) { + idx2 = idx1 - 1; + idx1 = 0; + goto dropEnd; + } else { + if (idx1 > 0) { + tmpObj = Tcl_NewIntObj(idx1); + Tcl_IncrRefCount(tmpObj); + } + goto dropRange; + } + } + + tokenPtr = TokenAfter(tokenPtr); + for (i=4 ; inumWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4( INST_LIST, i - 4, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); if (idx1 == 0) { if (idx2 == -2) { - guaranteedDropAll = 1; + goto replaceAll; } idx1 = idx2 + 1; idx2 = -2; + goto replaceHead; } else if (idx2 == -2) { idx2 = idx1 - 1; idx1 = 0; + goto replaceTail; } else { - return TCL_ERROR; + if (idx1 > 0 && idx2 > 0 && idx2 < idx1) { + idx2 = idx1 - 1; + } else if (idx1 < 0 && idx2 < 0 && idx2 < idx1) { + idx2 = idx1 - 1; + } + if (idx1 > 0) { + tmpObj = Tcl_NewIntObj(idx1); + Tcl_IncrRefCount(tmpObj); + } + goto replaceRange; } /* - * Issue instructions. It's not safe to skip doing the LIST_RANGE, as - * we've not proved that the 'list' argument is really a list. Not that it - * is worth trying to do that given current knowledge. + * Issue instructions to perform the operations relating to configurations + * that just drop. The only argument pushed on the stack is the list to + * operate on. */ - CompileWord(envPtr, listTokenPtr, interp, 1); - if (guaranteedDropAll) { + dropAll: + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushStringLiteral(envPtr, ""); + goto done; + + dropEnd: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + goto done; + + dropRange: + if (tmpObj != NULL) { + TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, ""); - } else { - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); + TclEmitOpcode( INST_GT, envPtr); + offset = 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); + } + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); + TclEmitInt4( -2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + /* + * Issue instructions to perform the operations relating to configurations + * that do real replacement. All arguments are pushed and assembled into a + * pair: the list of values to replace with, and the list to do the + * surgery on. + */ + + replaceAll: + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + goto done; + + replaceHead: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + replaceTail: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + replaceRange: + if (tmpObj != NULL) { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); + TclEmitOpcode( INST_GT, envPtr); + offset = 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); + } + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); + TclEmitInt4( -2, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + /* + * Clean up the allocated memory. + */ + + done: + if (tmpObj != NULL) { + Tcl_DecrRefCount(tmpObj); } return TCL_OK; } -- cgit v0.12 From 7fc9ecd5ab04d78ef215ca8610ef85cb77402746 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 3 Oct 2013 13:32:06 +0000 Subject: cleaner and faster 'string trim' --- generic/tclAssembly.c | 3 ++- generic/tclCompCmdsSZ.c | 24 ++---------------------- generic/tclCompile.c | 5 +++++ generic/tclCompile.h | 7 ++++--- generic/tclExecute.c | 34 ++++++++++++++++++++++++++++------ 5 files changed, 41 insertions(+), 32 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 659f483..44cddba 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -462,6 +462,7 @@ static const TalInstDesc TalInstructionTable[] = { {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, + {"strtrim", ASSEM_1BYTE, INST_STRTRIM, 2, 1}, {"strtrimLeft", ASSEM_1BYTE, INST_STRTRIM_LEFT, 2, 1}, {"strtrimRight", ASSEM_1BYTE, INST_STRTRIM_RIGHT, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, @@ -505,7 +506,7 @@ static const unsigned char NonThrowingByteCodes[] = { INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ INST_RESOLVE_COMMAND, /* 154 */ - INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166,167 */ + INST_STRTRIM, INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166-168 */ }; /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0177b2d..12f6167 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -739,7 +739,6 @@ TclCompileStringTrimCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; @@ -749,30 +748,11 @@ TclCompileStringTrimCmd( CompileWord(envPtr, tokenPtr, interp, 1); if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); - TclNewObj(objPtr); - if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - int len; - const char *p = Tcl_GetStringFromObj(objPtr, &len); - - PushLiteral(envPtr, p, len); - OP( STRTRIM_LEFT); - PushLiteral(envPtr, p, len); - OP( STRTRIM_RIGHT); - } else { - CompileWord(envPtr, tokenPtr, interp, 2); - OP4( REVERSE, 2); - OP4( OVER, 1); - OP( STRTRIM_LEFT); - OP4( REVERSE, 2); - OP( STRTRIM_RIGHT); - } - TclDecrRefCount(objPtr); + CompileWord(envPtr, tokenPtr, interp, 2); } else { PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); - OP( STRTRIM_LEFT); - PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); - OP( STRTRIM_RIGHT); } + OP( STRTRIM); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cdedbda..7e72d84 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -545,6 +545,11 @@ InstructionDesc const tclInstructionTable[] = { /* Drops an element from the auxiliary stack, popping stack elements * until the matching stack depth is reached. */ + {"strtrim", 1, -1, 0, {OPERAND_NONE}}, + /* [string trim] core: removes the characters (designated by the value + * at the top of the stack) from both ends of the string and pushes + * the resulting string. + * Stack: ... string charset => ... trimmedString */ {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}}, /* [string trimleft] core: removes the characters (designated by the * value at the top of the stack) from the left of the string and diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 08eb393..fa8d773 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -769,11 +769,12 @@ typedef struct ByteCode { #define INST_EXPAND_DROP 165 /* For compilation of [string trim] and related */ -#define INST_STRTRIM_LEFT 166 -#define INST_STRTRIM_RIGHT 167 +#define INST_STRTRIM 166 +#define INST_STRTRIM_LEFT 167 +#define INST_STRTRIM_RIGHT 168 /* The last opcode */ -#define LAST_INST_OPCODE 167 +#define LAST_INST_OPCODE 168 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 83f68fd..8470389 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5258,19 +5258,41 @@ TEBCresume( { const char *string1, *string2; + int trim1, trim2; + case INST_STRTRIM: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim1 = TclTrimLeft(string1, length, string2, length2); + if (trim1 < length) { + trim2 = TclTrimRight(string1, length, string2, length2); + } else { + trim2 = 0; + } + if (trim1 == 0 && trim2 == 0) { + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), + valuePtr); + NEXT_INST_F(1, 1, 0); + } else { + objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), + objResultPtr); + NEXT_INST_F(1, 2, 1); + } case INST_STRTRIM_LEFT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); string1 = TclGetStringFromObj(valuePtr, &length); - match = TclTrimLeft(string1, length, string2, length2); - if (match == 0) { + trim1 = TclTrimLeft(string1, length, string2, length2); + if (trim1 == 0) { TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), valuePtr); NEXT_INST_F(1, 1, 0); } else { - objResultPtr = Tcl_NewStringObj(string1+match, length-match); + objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1); TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), objResultPtr); NEXT_INST_F(1, 2, 1); @@ -5280,11 +5302,11 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); string1 = TclGetStringFromObj(valuePtr, &length); - match = TclTrimRight(string1, length, string2, length2); - if (match == 0) { + trim2 = TclTrimRight(string1, length, string2, length2); + if (trim2 == 0) { NEXT_INST_F(1, 1, 0); } else { - objResultPtr = Tcl_NewStringObj(string1, length-match); + objResultPtr = Tcl_NewStringObj(string1, length-trim2); NEXT_INST_F(1, 2, 1); } } -- cgit v0.12 From d9b2d9628aa30bf11a0448347393acffa336a3e0 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 5 Oct 2013 13:53:30 +0000 Subject: Added 'linsert' compiler. Factored out constant list index parser. --- generic/tclBasic.c | 2 +- generic/tclCompCmdsGR.c | 278 +++++++++++++++++++++++++++--------------------- generic/tclInt.h | 3 + 3 files changed, 160 insertions(+), 123 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a41351e..9f40932 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -227,7 +227,7 @@ static const CmdInfo builtInCmds[] = { {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, - {"linsert", Tcl_LinsertObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index e695068..c5a0126 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -27,7 +27,57 @@ static void CompileReturnInternal(CompileEnv *envPtr, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); + +/* + *---------------------------------------------------------------------- + * + * TclCompileLinsertCmd -- + * + * Parse a token and get the encoded version of the index (as understood + * by TEBC), assuming it is at all knowable at compile time. Only handles + * indices that are integers or 'end' or 'end-integer'. + * + * Returns: + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * + * Side effects: + * Sets *index to the index value if successful. + * + *---------------------------------------------------------------------- + */ + +static inline int +GetIndexFromToken( + Tcl_Token *tokenPtr, + int *index) +{ + Tcl_Obj *tmpObj = Tcl_NewObj(); + int result, idx; + + if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { + Tcl_DecrRefCount(tmpObj); + return TCL_ERROR; + } + result = TclGetIntFromObj(NULL, tmpObj, &idx); + if (result == TCL_OK) { + if (idx < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); + if (result == TCL_OK && idx > -2) { + result = TCL_ERROR; + } + } + Tcl_DecrRefCount(tmpObj); + + if (result == TCL_OK) { + *index = idx; + } + + return result; +} /* *---------------------------------------------------------------------- @@ -1060,7 +1110,7 @@ TclCompileLindexCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *idxTokenPtr, *valTokenPtr; - int i, numWords = parsePtr->numWords; + int i, idx, numWords = parsePtr->numWords; DefineLineInformation; /* TIP #280 */ /* @@ -1078,46 +1128,28 @@ TclCompileLindexCmd( } idxTokenPtr = TokenAfter(valTokenPtr); - if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_Obj *tmpObj; - int idx, result; - - tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx); - if (result == TCL_OK) { - if (idx < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); - if (result == TCL_OK && idx > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - - if (result == TCL_OK) { - /* - * All checks have been completed, and we have exactly one of - * these constructs: - * lindex - * lindex end- - * This is best compiled as a push of the arbitrary value followed - * by an "immediate lindex" which is the most efficient variety. - */ - - CompileWord(envPtr, valTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); - return TCL_OK; - } - + if (GetIndexFromToken(idxTokenPtr, &idx) == TCL_OK) { /* - * If the conversion failed or the value was negative, we just keep on - * going with the more complex compilation. + * All checks have been completed, and we have exactly one of these + * constructs: + * lindex + * lindex end- + * This is best compiled as a push of the arbitrary value followed by + * an "immediate lindex" which is the most efficient variety. */ + + CompileWord(envPtr, valTokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); + return TCL_OK; } /* + * If the value was not known at compile time, the conversion failed or + * the value was negative, we just keep on going with the more complex + * compilation. + */ + + /* * Push the operands onto the stack. */ @@ -1330,8 +1362,7 @@ TclCompileLrangeCmd( { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *tmpObj; - int idx1, idx2, result; + int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; @@ -1339,56 +1370,18 @@ TclCompileLrangeCmd( listTokenPtr = TokenAfter(parsePtr->tokenPtr); /* - * Parse the first index. Will only compile if it is constant and not an + * Parse the indices. Will only compile if both are constants and not an * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * end-relative indexing) or an end-based index greater than 'end' itself. */ tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { return TCL_ERROR; } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { return TCL_ERROR; } @@ -1407,19 +1400,16 @@ TclCompileLrangeCmd( /* *---------------------------------------------------------------------- * - * TclCompileLreplaceCmd -- + * TclCompileLinsertCmd -- * - * How to compile the "lreplace" command. We only bother with the case - * where there are no elements to insert and where both the 'first' and - * 'last' arguments are constant and one can be deterined to be at the - * end of the list. (This is the case that could also be written with - * "lrange".) + * How to compile the "linsert" command. We only bother with the case + * where the index is constant. * *---------------------------------------------------------------------- */ int -TclCompileLreplaceCmd( +TclCompileLinsertCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ @@ -1429,65 +1419,109 @@ TclCompileLreplaceCmd( { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *tmpObj; - int idx1, idx2, result, i, offset; + int idx, i; - if (parsePtr->numWords < 4) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); /* - * Parse the first index. Will only compile if it is constant and not an + * Parse the index. Will only compile if it is constant and not an * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * end-relative indexing) or an end-based index greater than 'end' itself. */ tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + if (GetIndexFromToken(tokenPtr, &idx) != TCL_OK) { return TCL_ERROR; } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } + + /* + * There are four main cases. If there are no values to insert, this is + * just a confirm-listiness check. If the index is '0', this is a prepend. + * If the index is 'end' (== -2), this is an append. Otherwise, this is a + * splice (== split, insert values as list, concat-3). + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( -2, envPtr); + return TCL_OK; + } + + for (i=3 ; inumWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + TclEmitInstInt4( INST_LIST, i-3, envPtr); + + if (idx == 0 /*start*/) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } else if (idx == -2 /*end*/) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; + if (idx < 0) { + idx++; } + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx-1, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4( -2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLreplaceCmd -- + * + * How to compile the "lreplace" command. We only bother with the case + * where the indices are constant. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLreplaceCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *listTokenPtr; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *tmpObj; + int idx1, idx2, i, offset; + + if (parsePtr->numWords < 4) { return TCL_ERROR; } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); /* - * Parse the second index. Will only compile if it is constant and not an + * Parse the indices. Will only compile if both are constants and not an * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * end-relative indexing) or an end-based index greater than 'end' itself. */ - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + tokenPtr = TokenAfter(listTokenPtr); + if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { return TCL_ERROR; } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + + tokenPtr = TokenAfter(tokenPtr); + if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 2312734..6fe07f8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3533,6 +3533,9 @@ MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLinsertCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From a1ae4070993b7b225719352db81a4acd872b751e Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 6 Oct 2013 13:21:10 +0000 Subject: Factor out some knowledge of immediate index encoding. --- generic/tclCompCmdsGR.c | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index c5a0126..c5dddcb 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -27,6 +27,8 @@ static void CompileReturnInternal(CompileEnv *envPtr, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); + +#define INDEX_END (-2) /* *---------------------------------------------------------------------- @@ -65,8 +67,8 @@ GetIndexFromToken( result = TCL_ERROR; } } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); - if (result == TCL_OK && idx > -2) { + result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx); + if (result == TCL_OK && idx > INDEX_END) { result = TCL_ERROR; } } @@ -1077,7 +1079,7 @@ TclCompileLassignCmd( */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( -2 /* == "end" */, envPtr); + TclEmitInt4( INDEX_END, envPtr); return TCL_OK; } @@ -1295,7 +1297,7 @@ TclCompileListCmd( if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( INDEX_END, envPtr); } return TCL_OK; } @@ -1440,14 +1442,14 @@ TclCompileLinsertCmd( /* * There are four main cases. If there are no values to insert, this is * just a confirm-listiness check. If the index is '0', this is a prepend. - * If the index is 'end' (== -2), this is an append. Otherwise, this is a - * splice (== split, insert values as list, concat-3). + * If the index is 'end' (== INDEX_END), this is an append. Otherwise, + * this is a splice (== split, insert values as list, concat-3). */ CompileWord(envPtr, listTokenPtr, interp, 1); if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( INDEX_END, envPtr); return TCL_OK; } @@ -1460,7 +1462,7 @@ TclCompileLinsertCmd( if (idx == 0 /*start*/) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else if (idx == -2 /*end*/) { + } else if (idx == INDEX_END /*end*/) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { if (idx < 0) { @@ -1471,7 +1473,7 @@ TclCompileLinsertCmd( TclEmitInt4( idx-1, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( INDEX_END, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); } @@ -1533,13 +1535,13 @@ TclCompileLreplaceCmd( CompileWord(envPtr, listTokenPtr, interp, 1); if (parsePtr->numWords == 4) { if (idx1 == 0) { - if (idx2 == -2) { + if (idx2 == INDEX_END) { goto dropAll; } idx1 = idx2 + 1; - idx2 = -2; + idx2 = INDEX_END; goto dropEnd; - } else if (idx2 == -2) { + } else if (idx2 == INDEX_END) { idx2 = idx1 - 1; idx1 = 0; goto dropEnd; @@ -1560,13 +1562,13 @@ TclCompileLreplaceCmd( TclEmitInstInt4( INST_LIST, i - 4, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); if (idx1 == 0) { - if (idx2 == -2) { + if (idx2 == INDEX_END) { goto replaceAll; } idx1 = idx2 + 1; - idx2 = -2; + idx2 = INDEX_END; goto replaceHead; - } else if (idx2 == -2) { + } else if (idx2 == INDEX_END) { idx2 = idx1 - 1; idx1 = 0; goto replaceTail; @@ -1620,7 +1622,7 @@ TclCompileLreplaceCmd( TclEmitInt4( idx1 - 1, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( INDEX_END, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); goto done; @@ -1669,7 +1671,7 @@ TclCompileLreplaceCmd( TclEmitInt4( idx1 - 1, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( INDEX_END, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); -- cgit v0.12 From 345c194b8e887d9dce3fcee01d78e5fc203624c1 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 Oct 2013 09:18:19 +0000 Subject: corrected trace printing --- generic/tclExecute.c | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8470389..6357008 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5272,13 +5272,13 @@ TEBCresume( trim2 = 0; } if (trim1 == 0 && trim2 == 0) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), - valuePtr); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), valuePtr); NEXT_INST_F(1, 1, 0); } else { objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), - objResultPtr); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), objResultPtr); NEXT_INST_F(1, 2, 1); } case INST_STRTRIM_LEFT: @@ -5288,13 +5288,13 @@ TEBCresume( string1 = TclGetStringFromObj(valuePtr, &length); trim1 = TclTrimLeft(string1, length, string2, length2); if (trim1 == 0) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), - valuePtr); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), valuePtr); NEXT_INST_F(1, 1, 0); } else { objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1); - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), - objResultPtr); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), objResultPtr); NEXT_INST_F(1, 2, 1); } case INST_STRTRIM_RIGHT: @@ -5304,9 +5304,13 @@ TEBCresume( string1 = TclGetStringFromObj(valuePtr, &length); trim2 = TclTrimRight(string1, length, string2, length2); if (trim2 == 0) { + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), valuePtr); NEXT_INST_F(1, 1, 0); } else { objResultPtr = Tcl_NewStringObj(string1, length-trim2); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), objResultPtr); NEXT_INST_F(1, 2, 1); } } -- cgit v0.12 From 2ffe17a9b38fafe543673604a657bea1477bb4ea Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 Oct 2013 17:34:55 +0000 Subject: Fix for assemble.test; problem was a total assumption failure caused by way that the assembler works. --- generic/tclAssembly.c | 34 +++------------------------------- 1 file changed, 3 insertions(+), 31 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index fc51457..03177b9 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -246,8 +246,6 @@ static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx, int opnd, int count); static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx, int param, int count); -static void BBEmitInvoke1or4(AssemblyEnv* assemEnvPtr, int tblIdx, - int param, int count); static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx, int count); static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr); @@ -681,13 +679,10 @@ BBEmitInstInt4( /* *----------------------------------------------------------------------------- * - * BBEmitInst1or4, BBEmitInvoke1or4 -- + * BBEmitInst1or4 -- * * Emits a 1- or 4-byte operation according to the magnitude of the - * operand. The Invoke variant generates wrapping stack-balance - * management if necessary (which is not normally required in assembled - * code, as loop exception ranges, expansions, breaks and continues can't - * be issued currently). + * operand. * *----------------------------------------------------------------------------- */ @@ -719,29 +714,6 @@ BBEmitInst1or4( TclUpdateAtCmdStart(op, envPtr); BBUpdateStackReqs(bbPtr, tblIdx, count); } - -static void -BBEmitInvoke1or4( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int param, /* Variable-length parameter */ - int count) /* Arity if variadic */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr = assemEnvPtr->curr_bb; - /* Current basic block */ - int op = TalInstructionTable[tblIdx].tclInstCode; - - if (param <= 0xff) { - op >>= 8; - } else { - op &= 0xff; - } - TclEmitInvoke(envPtr, op, param); - TclUpdateAtCmdStart(op, envPtr); - BBUpdateStackReqs(bbPtr, tblIdx, count); -} /* *----------------------------------------------------------------------------- @@ -1478,7 +1450,7 @@ AssembleOneLine( goto cleanup; } - BBEmitInvoke1or4(assemEnvPtr, tblIdx, opnd, opnd); + BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); break; case ASSEM_JUMP: -- cgit v0.12 From cc5f831d9087599b3c03d6f7266ddf6fe1edc063 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 23 Oct 2013 08:33:40 +0000 Subject: Stack depth calculation correction. --- generic/tclCompCmdsGR.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 2aaca31..a02f0a8 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1616,6 +1616,7 @@ TclCompileLreplaceCmd( Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); + TclAdjustStackDepth(-1, envPtr); } TclEmitOpcode( INST_DUP, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); @@ -1665,6 +1666,7 @@ TclCompileLreplaceCmd( Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); + TclAdjustStackDepth(-1, envPtr); } TclEmitOpcode( INST_DUP, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); -- cgit v0.12 From edff530f8d1dba156327e87e39ef803ea58ebe8a Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 24 Oct 2013 07:21:14 +0000 Subject: First step in compiling [concat]: the trivial cases. --- generic/tclBasic.c | 2 +- generic/tclCompCmds.c | 86 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 ++ 3 files changed, 90 insertions(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9f40932..8d77cc5 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -211,7 +211,7 @@ static const CmdInfo builtInCmds[] = { {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, #endif {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, - {"concat", Tcl_ConcatObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9c43bfe..9508d00 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -55,6 +55,13 @@ const AuxDataType tclDictUpdateInfoType = { FreeDictUpdateInfo, /* freeProc */ PrintDictUpdateInfo /* printProc */ }; + +/* + * The definition of what whitespace is stripped when [concat]enating. Must be + * kept in synch with tclUtil.c + */ + +#define CONCAT_WS " \f\v\r\t\n" /* *---------------------------------------------------------------------- @@ -748,6 +755,85 @@ TclCompileCatchCmd( /* *---------------------------------------------------------------------- * + * TclCompileConcatCmd -- + * + * Procedure called to compile the "concat" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "concat" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileConcatCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Obj *objPtr, *listObj; + Tcl_Token *tokenPtr; + int i; + + if (parsePtr->numWords == 1) { + /* + * [concat] without arguments just pushes an empty object. + */ + + PushStringLiteral(envPtr, ""); + return TCL_OK; + } + + /* + * Test if all arguments are compile-time known. If they are, we can + * implement with a simple push. + */ + + listObj = Tcl_NewObj(); + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + objPtr = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(listObj); + listObj = NULL; + break; + } + (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); + } + if (listObj != NULL) { + Tcl_Obj **objs; + const char *bytes; + int len; + + Tcl_ListObjGetElements(NULL, listObj, &len, &objs); + objPtr = Tcl_ConcatObj(len, objs); + Tcl_DecrRefCount(listObj); + bytes = Tcl_GetStringFromObj(objPtr, &len); + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(objPtr); + return TCL_OK; + } + + /* + * General case: runtime concat. + */ + + // TODO + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileContinueCmd -- * * Procedure called to compile the "continue" command. diff --git a/generic/tclInt.h b/generic/tclInt.h index 6fe07f8..cc8469b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3434,6 +3434,9 @@ MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileConcatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From f663a0f78dfd7409ced97e98402bb3c0419c5d4a Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 26 Oct 2013 07:50:08 +0000 Subject: Change name of instruction to make way for future changes. --- generic/tclAssembly.c | 3 ++- generic/tclCompCmds.c | 4 ++-- generic/tclCompCmdsSZ.c | 12 ++++++------ generic/tclCompile.c | 10 +++++----- generic/tclCompile.h | 2 +- generic/tclExecute.c | 2 +- generic/tclOptimize.c | 6 +++--- 7 files changed, 20 insertions(+), 19 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 4c0777d..f709acb 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -349,7 +349,7 @@ static const TalInstDesc TalInstructionTable[] = { {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, - {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, + {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, @@ -453,6 +453,7 @@ static const TalInstDesc TalInstructionTable[] = { {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, + {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9508d00..a1ccd39 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1825,7 +1825,7 @@ TclCompileDictAppendCmd( tokenPtr = TokenAfter(tokenPtr); } if (parsePtr->numWords > 4) { - TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); } /* @@ -3212,7 +3212,7 @@ TclCompileFormatCmd( * Do the concatenation, which produces the result. */ - TclEmitInstInt1(INST_CONCAT1, i, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr); } else { /* * EVIL HACK! Force there to be a string representation in the case diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 5f7fad3..646adf3 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -867,7 +867,7 @@ TclSubstCompile( /* * Tricky point! If the first token does not result in a *guaranteed* push * of a Tcl_Obj on the stack, we must push an empty object. Otherwise it - * is possible to get to an INST_CONCAT1 or INST_DONE without enough + * is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough * values on the stack, resulting in a crash. Thanks to Joe Mistachkin for * identifying a script that could trigger this case. */ @@ -932,11 +932,11 @@ TclSubstCompile( } while (count > 255) { - OP1( CONCAT1, 255); + OP1( STR_CONCAT1, 255); count -= 254; } if (count > 1) { - OP1( CONCAT1, count); + OP1( STR_CONCAT1, count); count = 1; } @@ -1056,7 +1056,7 @@ TclSubstCompile( (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { - OP1(CONCAT1, count); + OP1(STR_CONCAT1, count); count = 1; } @@ -1069,11 +1069,11 @@ TclSubstCompile( } while (count > 255) { - OP1( CONCAT1, 255); + OP1( STR_CONCAT1, 255); count -= 254; } if (count > 1) { - OP1( CONCAT1, count); + OP1( STR_CONCAT1, count); } Tcl_FreeParse(&parse); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cfc6b2e..48a5456 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -63,7 +63,7 @@ InstructionDesc const tclInstructionTable[] = { /* Pop the topmost stack object */ {"dup", 1, +1, 0, {OPERAND_NONE}}, /* Duplicate the topmost stack object and push the result */ - {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + {"strcat", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Concatenate the top op1 items and push result */ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; = */ @@ -2400,11 +2400,11 @@ TclCompileTokens( */ while (numObjsToConcat > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } if (numObjsToConcat > 1) { - TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, numObjsToConcat, envPtr); } /* @@ -2535,11 +2535,11 @@ TclCompileExprWords( } concatItems = 2*numWords - 1; while (concatItems > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); concatItems -= 254; } if (concatItems > 1) { - TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, concatItems, envPtr); } TclEmitOpcode(INST_EXPR_STK, envPtr); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index db77eb1..62c41ea 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -512,7 +512,7 @@ typedef struct ByteCode { #define INST_PUSH4 2 #define INST_POP 3 #define INST_DUP 4 -#define INST_CONCAT1 5 +#define INST_STR_CONCAT1 5 #define INST_INVOKE_STK1 6 #define INST_INVOKE_STK4 7 #define INST_EVAL_STK 8 diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6357008..ab7a3f5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2563,7 +2563,7 @@ TEBCresume( NEXT_INST_F(5, 0, 0); } - case INST_CONCAT1: { + case INST_STR_CONCAT1: { int appendLen = 0; char *bytes, *p; Tcl_Obj **currPtr; diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 3b16e6e..3196b83 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -191,7 +191,7 @@ TrimUnreachable( * ConvertZeroEffectToNOP -- * * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also - * replace PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an + * replace PUSH empty/STR_CONCAT and TRY_CVT_NUMERIC (when followed by an * operation that guarantees the check for arithmeticity) and eliminate * LNOT when we can invert the following JUMP condition. * @@ -227,7 +227,7 @@ ConvertZeroEffectToNOP( case INST_PUSH1: if (nextInst == INST_POP) { blank = size + InstLength(nextInst); - } else if (nextInst == INST_CONCAT1 + } else if (nextInst == INST_STR_CONCAT1 && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt1AtPtr(currentInstPtr + 1)); @@ -242,7 +242,7 @@ ConvertZeroEffectToNOP( case INST_PUSH4: if (nextInst == INST_POP) { blank = size + 1; - } else if (nextInst == INST_CONCAT1 + } else if (nextInst == INST_STR_CONCAT1 && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt4AtPtr(currentInstPtr + 1)); -- cgit v0.12 From 9cc416d585cd447bebe8c27298198f3101b7d6f2 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 26 Oct 2013 08:25:02 +0000 Subject: General [concat] compilation. --- generic/tclAssembly.c | 5 ++++- generic/tclCompCmds.c | 12 ++++++++++-- generic/tclCompile.c | 6 +++++- generic/tclCompile.h | 4 +++- generic/tclExecute.c | 11 +++++++++++ 5 files changed, 33 insertions(+), 5 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index f709acb..b805c63 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -350,6 +350,7 @@ static const TalInstDesc TalInstructionTable[] = { {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, + {"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1}, {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, @@ -497,6 +498,7 @@ static const unsigned char NonThrowingByteCodes[] = { INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ INST_JUMP1, INST_JUMP4, /* 34-35 */ INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ + INST_LIST, /* 79 */ INST_OVER, /* 95 */ INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ @@ -507,7 +509,8 @@ static const unsigned char NonThrowingByteCodes[] = { INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ INST_RESOLVE_COMMAND, /* 154 */ - INST_STRTRIM, INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166-168 */ + INST_STRTRIM, INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT, /* 166-168 */ + INST_CONCAT_STK /* 169 */ }; /* diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a1ccd39..2f6cb96 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -779,10 +779,12 @@ TclCompileConcatCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Obj *objPtr, *listObj; Tcl_Token *tokenPtr; int i; + /* TODO: Consider compiling expansion case. */ if (parsePtr->numWords == 1) { /* * [concat] without arguments just pushes an empty object. @@ -827,8 +829,14 @@ TclCompileConcatCmd( * General case: runtime concat. */ - // TODO - return TCL_ERROR; + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + + TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); + + return TCL_OK; } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 48a5456..280bf64 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -561,6 +561,11 @@ InstructionDesc const tclInstructionTable[] = { * pushes the resulting string. * Stack: ... string charset => ... trimmedString */ + {"concatStk", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Wrapper round Tcl_ConcatObj(), used for [concat] and [eval]. opnd + * is number of values to concatenate. + * Operation: push concat(stk1 stk2 ... stktop) */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -4050,7 +4055,6 @@ TclEmitInvoke( int savedStackDepth = envPtr->currStackDepth; int savedExpandCount = envPtr->expandCount; JumpFixup nonTrapFixup; - ExceptionAux *exceptAux = envPtr->exceptAuxArrayPtr + loopRange; if (auxBreakPtr != NULL) { auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 62c41ea..4ae754c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -773,8 +773,10 @@ typedef struct ByteCode { #define INST_STRTRIM_LEFT 167 #define INST_STRTRIM_RIGHT 168 +#define INST_CONCAT_STK 169 + /* The last opcode */ -#define LAST_INST_OPCODE 168 +#define LAST_INST_OPCODE 169 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ab7a3f5..cb6afaf 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2712,6 +2712,17 @@ TEBCresume( NEXT_INST_V(2, opnd, 1); } + case INST_CONCAT_STK: + /* + * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj, + * and then decrement their ref counts. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(5, opnd, 1); + case INST_EXPAND_START: /* * Push an element to the auxObjList. This records the current -- cgit v0.12 From bc8401949587c09eb56c1b50d773c6a07e6d66aa Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 29 Oct 2013 20:07:56 +0000 Subject: Now do [string toupper], [string tolower] and [string totitle]. Only handles the no-indices case; that's the only case anyone actually commonly uses. --- generic/tclAssembly.c | 14 ++-- generic/tclCmdMZ.c | 6 +- generic/tclCompCmdsGR.c | 2 +- generic/tclCompCmdsSZ.c | 171 +++++++++++++++++++++++++++++++++++------------- generic/tclCompile.c | 13 ++++ generic/tclCompile.h | 12 ++-- generic/tclExecute.c | 55 +++++++++++++++- generic/tclInt.h | 9 +++ 8 files changed, 221 insertions(+), 61 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index b805c63..cd0a42d 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -453,6 +453,9 @@ static const TalInstDesc TalInstructionTable[] = { | INST_STORE_ARRAY4), 2, 1}, {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, + {"strLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, + {"strTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, + {"strUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, @@ -464,9 +467,9 @@ static const TalInstDesc TalInstructionTable[] = { {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, - {"strtrim", ASSEM_1BYTE, INST_STRTRIM, 2, 1}, - {"strtrimLeft", ASSEM_1BYTE, INST_STRTRIM_LEFT, 2, 1}, - {"strtrimRight", ASSEM_1BYTE, INST_STRTRIM_RIGHT, 2, 1}, + {"strtrim", ASSEM_1BYTE, INST_STR_TRIM, 2, 1}, + {"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1}, + {"strtrimRight", ASSEM_1BYTE, INST_STR_TRIM_RIGHT, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, @@ -509,8 +512,9 @@ static const unsigned char NonThrowingByteCodes[] = { INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ INST_RESOLVE_COMMAND, /* 154 */ - INST_STRTRIM, INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT, /* 166-168 */ - INST_CONCAT_STK /* 169 */ + INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ + INST_CONCAT_STK, /* 169 */ + INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE /* 170-172 */ }; /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 2b5e995..da8ffe3 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3341,9 +3341,9 @@ TclInitStringCmd( {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"tolower", StringLowerCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"toupper", StringUpperCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"totitle", StringTitleCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"tolower", StringLowerCmd, TclCompileStringToLowerCmd, NULL, NULL, 0}, + {"toupper", StringUpperCmd, TclCompileStringToUpperCmd, NULL, NULL, 0}, + {"totitle", StringTitleCmd, TclCompileStringToTitleCmd, NULL, NULL, 0}, {"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0}, {"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0}, {"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index a02f0a8..50fb8e9 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -33,7 +33,7 @@ static int IndexTailVarIfKnown(Tcl_Interp *interp, /* *---------------------------------------------------------------------- * - * TclCompileLinsertCmd -- + * GetIndexFromToken -- * * Parse a token and get the encoded version of the index (as understood * by TEBC), assuming it is at all knowable at compile time. Only handles diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 646adf3..ca4b316 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -101,6 +101,59 @@ const AuxDataType tclJumptableInfoType = { if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} #define INVOKE(name) \ TclEmitInvoke(envPtr,INST_##name) + +#define INDEX_END (-2) + +/* + *---------------------------------------------------------------------- + * + * GetIndexFromToken -- + * + * Parse a token and get the encoded version of the index (as understood + * by TEBC), assuming it is at all knowable at compile time. Only handles + * indices that are integers or 'end' or 'end-integer'. + * + * Returns: + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * + * Side effects: + * Sets *index to the index value if successful. + * + *---------------------------------------------------------------------- + */ + +static inline int +GetIndexFromToken( + Tcl_Token *tokenPtr, + int *index) +{ + Tcl_Obj *tmpObj = Tcl_NewObj(); + int result, idx; + + if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { + Tcl_DecrRefCount(tmpObj); + return TCL_ERROR; + } + + result = TclGetIntFromObj(NULL, tmpObj, &idx); + if (result == TCL_OK) { + if (idx < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx); + if (result == TCL_OK && idx > INDEX_END) { + result = TCL_ERROR; + } + } + Tcl_DecrRefCount(tmpObj); + + if (result == TCL_OK) { + *index = idx; + } + + return result; +} /* *---------------------------------------------------------------------- @@ -565,8 +618,7 @@ TclCompileStringRangeCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr; - Tcl_Obj *tmpObj; - int idx1, idx2, result; + int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; @@ -576,50 +628,13 @@ TclCompileStringRangeCmd( toTokenPtr = TokenAfter(fromTokenPtr); /* - * Parse the first index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * Parse the two indices. */ - tmpObj = Tcl_NewObj(); - result = TCL_ERROR; - if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) { - if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) { - if (idx1 >= 0) { - result = TCL_OK; - } - } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) { - if (idx1 <= -2) { - result = TCL_OK; - } - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + if (GetIndexFromToken(fromTokenPtr, &idx1) != TCL_OK) { goto nonConstantIndices; } - - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tmpObj = Tcl_NewObj(); - result = TCL_ERROR; - if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) { - if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) { - if (idx2 >= 0) { - result = TCL_OK; - } - } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) { - if (idx2 <= -2) { - result = TCL_OK; - } - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + if (GetIndexFromToken(toTokenPtr, &idx2) != TCL_OK) { goto nonConstantIndices; } @@ -698,7 +713,7 @@ TclCompileStringTrimLCmd( } else { PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); } - OP( STRTRIM_LEFT); + OP( STR_TRIM_LEFT); return TCL_OK; } @@ -726,7 +741,7 @@ TclCompileStringTrimRCmd( } else { PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); } - OP( STRTRIM_RIGHT); + OP( STR_TRIM_RIGHT); return TCL_OK; } @@ -754,7 +769,73 @@ TclCompileStringTrimCmd( } else { PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); } - OP( STRTRIM); + OP( STR_TRIM); + return TCL_OK; +} + +int +TclCompileStringToUpperCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2) { + return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + OP( STR_UPPER); + return TCL_OK; +} + +int +TclCompileStringToLowerCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2) { + return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + OP( STR_LOWER); + return TCL_OK; +} + +int +TclCompileStringToTitleCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2) { + return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + OP( STR_TITLE); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 280bf64..48165e6 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -566,6 +566,19 @@ InstructionDesc const tclInstructionTable[] = { * is number of values to concatenate. * Operation: push concat(stk1 stk2 ... stktop) */ + {"strUpper", 1, 0, 0, {OPERAND_NONE}}, + /* [string toupper] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strLower", 1, 0, 0, {OPERAND_NONE}}, + /* [string tolower] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strTitle", 1, 0, 0, {OPERAND_NONE}}, + /* [string totitle] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 4ae754c..1d21d39 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -769,14 +769,18 @@ typedef struct ByteCode { #define INST_EXPAND_DROP 165 /* For compilation of [string trim] and related */ -#define INST_STRTRIM 166 -#define INST_STRTRIM_LEFT 167 -#define INST_STRTRIM_RIGHT 168 +#define INST_STR_TRIM 166 +#define INST_STR_TRIM_LEFT 167 +#define INST_STR_TRIM_RIGHT 168 #define INST_CONCAT_STK 169 +#define INST_STR_UPPER 170 +#define INST_STR_LOWER 171 +#define INST_STR_TITLE 172 + /* The last opcode */ -#define LAST_INST_OPCODE 169 +#define LAST_INST_OPCODE 172 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index cb6afaf..3889ce0 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5002,6 +5002,55 @@ TEBCresume( TRACE(("%.20s => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); + case INST_STR_UPPER: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.25s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToUpper(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToUpper(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_LOWER: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.25s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToLower(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToLower(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_TITLE: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.25s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToTitle(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToTitle(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_INDEX: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; @@ -5271,7 +5320,7 @@ TEBCresume( const char *string1, *string2; int trim1, trim2; - case INST_STRTRIM: + case INST_STR_TRIM: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); @@ -5292,7 +5341,7 @@ TEBCresume( O2S(valuePtr), O2S(value2Ptr)), objResultPtr); NEXT_INST_F(1, 2, 1); } - case INST_STRTRIM_LEFT: + case INST_STR_TRIM_LEFT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); @@ -5308,7 +5357,7 @@ TEBCresume( O2S(valuePtr), O2S(value2Ptr)), objResultPtr); NEXT_INST_F(1, 2, 1); } - case INST_STRTRIM_RIGHT: + case INST_STR_TRIM_RIGHT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); diff --git a/generic/tclInt.h b/generic/tclInt.h index cc8469b..6806302 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3620,6 +3620,15 @@ MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToLowerCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToTitleCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToUpperCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringTrimCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 36434499c3efb22240ddc31f646e0e4d8379d672 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Nov 2013 08:23:05 +0000 Subject: Cygwin: Instead of checking whether the win32 part is configured properly, just configure it when needed. Always build the stub library first (and - on Cygwin - configure win32 properly just before building the stub library) --- unix/Makefile.in | 7 +++++-- unix/configure | 13 +++++++++---- unix/tcl.m4 | 11 +++++++++-- 3 files changed, 23 insertions(+), 8 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 210d90b..70d98c1 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -546,7 +546,7 @@ SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \ all: binaries libraries doc -binaries: ${LIB_FILE} $(STUB_LIB_FILE) ${TCL_EXE} +binaries: ${LIB_FILE} ${TCL_EXE} libraries: @@ -554,11 +554,14 @@ doc: # The following target is configured by autoconf to generate either a shared # library or non-shared library for Tcl. -${LIB_FILE}: ${OBJS} ${STUB_LIB_FILE} +${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} rm -f $@ @MAKE_LIB@ ${STUB_LIB_FILE}: ${STUB_LIB_OBJS} + @if test "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll"; then \ + (cd ${TOP_DIR}/win; ${MAKE} libtclstub${MAJOR_VERSION}${MINOR_VERSION}.a); \ + fi rm -f $@ @MAKE_STUB_LIB@ diff --git a/unix/configure b/unix/configure index d7bd53b..7f8922b 100755 --- a/unix/configure +++ b/unix/configure @@ -7007,10 +7007,15 @@ echo "$as_me: error: ${CC} is not a cygwin compiler." >&2;} echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2;} { (exit 1); exit 1; }; } fi - if test "x${SHARED_BUILD}" = "x1" -a ! -f "../win/tcldde13.dll" -a ! -f "../win/tk85.dll"; then - { { echo "$as_me:$LINENO: error: Please configure and make the ../win directory first." >&5 -echo "$as_me: error: Please configure and make the ../win directory first." >&2;} - { (exit 1); exit 1; }; } + do64bit_ok=yes + if test "x${SHARED_BUILD}" = "x1"; then + echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" + # The eval makes quoting arguments work. + if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix + then : + else + { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } + fi fi ;; dgux*) diff --git a/unix/tcl.m4 b/unix/tcl.m4 index f484989..e9795b8 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1263,8 +1263,15 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "x${TCL_THREADS}" = "x0"; then AC_MSG_ERROR([CYGWIN compile is only supported with --enable-threads]) fi - if test "x${SHARED_BUILD}" = "x1" -a ! -f "../win/tcldde13.dll" -a ! -f "../win/tk85.dll"; then - AC_MSG_ERROR([Please configure and make the ../win directory first.]) + do64bit_ok=yes + if test "x${SHARED_BUILD}" = "x1"; then + echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" + # The eval makes quoting arguments work. + if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix + then : + else + { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } + fi fi ;; dgux*) -- cgit v0.12 From ca48321a28f9238ba7db49e79ff1aabcaaf66162 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Nov 2013 09:09:42 +0000 Subject: Revert [5215b8740c] (Enh [2959069]), as it turns out that -fvisibility=hidden only affects definitions and not declarations. Therefore explicitely declaring each MODULE_SCOPE function as __attribute__((__visibility__("hidden")) is much better. Suggested by Stuart Cassoff (Thanks!). --- unix/configure | 83 +++------------------------------------------------------- unix/tcl.m4 | 30 +++++---------------- 2 files changed, 10 insertions(+), 103 deletions(-) diff --git a/unix/configure b/unix/configure index 06ff7a4..5009807 100755 --- a/unix/configure +++ b/unix/configure @@ -6490,80 +6490,6 @@ if test "${tcl_cv_cc_visibility_hidden+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - if test "$SHARED_BUILD" = 1; then - - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror" - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -int -main () -{ -#if !defined(__GNUC__) || __GNUC__ < 4 -#error visibility hidden is not supported for this compiler -#endif - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_cc_visibility_hidden=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -tcl_cv_cc_visibility_hidden=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - CFLAGS=$hold_cflags - -else - - tcl_cv_cc_visibility_hidden=no - -fi - - -fi -echo "$as_me:$LINENO: result: $tcl_cv_cc_visibility_hidden" >&5 -echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6 - if test $tcl_cv_cc_visibility_hidden = yes; then - - CFLAGS="$CFLAGS -fvisibility=hidden" - -cat >>confdefs.h <<\_ACEOF -#define MODULE_SCOPE extern -_ACEOF - - -else - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ @@ -6614,7 +6540,10 @@ fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags - if test $tcl_cv_cc_visibility_hidden = yes; then +fi +echo "$as_me:$LINENO: result: $tcl_cv_cc_visibility_hidden" >&5 +echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6 + if test $tcl_cv_cc_visibility_hidden = yes; then cat >>confdefs.h <<\_ACEOF @@ -6630,9 +6559,6 @@ _ACEOF fi -fi - - # Step 0.d: Disable -rpath support? echo "$as_me:$LINENO: checking if rpath support is requested" >&5 @@ -8145,7 +8071,6 @@ cat >>confdefs.h <<\_ACEOF #define MODULE_SCOPE __private_extern__ _ACEOF - tcl_cv_cc_visibility_hidden=yes fi diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 194cf90..e3a0d15 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1045,34 +1045,17 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK([if compiler supports visibility "hidden"], tcl_cv_cc_visibility_hidden, [ - AS_IF([test "$SHARED_BUILD" = 1], [ - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror" - AC_TRY_COMPILE(,[#if !defined(__GNUC__) || __GNUC__ < 4 -#error visibility hidden is not supported for this compiler -#endif - ], tcl_cv_cc_visibility_hidden=yes, - tcl_cv_cc_visibility_hidden=no) - CFLAGS=$hold_cflags - ], [ - tcl_cv_cc_visibility_hidden=no - ]) - ]) - AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ - CFLAGS="$CFLAGS -fvisibility=hidden" - AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden]) - ], [ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" AC_TRY_LINK([ extern __attribute__((__visibility__("hidden"))) void f(void); void f(void) {}], [f();], tcl_cv_cc_visibility_hidden=yes, tcl_cv_cc_visibility_hidden=no) - CFLAGS=$hold_cflags - AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ - AC_DEFINE(MODULE_SCOPE, - [extern __attribute__((__visibility__("hidden")))], - [Compiler support for module scope symbols]) - AC_DEFINE(HAVE_HIDDEN, [1], [Compiler support for module scope symbols]) - ]) + CFLAGS=$hold_cflags]) + AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ + AC_DEFINE(MODULE_SCOPE, + [extern __attribute__((__visibility__("hidden")))], + [Compiler support for module scope symbols]) + AC_DEFINE(HAVE_HIDDEN, [1], [Compiler support for module scope symbols]) ]) # Step 0.d: Disable -rpath support? @@ -1638,7 +1621,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ AC_DEFINE(MODULE_SCOPE, [__private_extern__], [Compiler support for module scope symbols]) - tcl_cv_cc_visibility_hidden=yes ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" -- cgit v0.12 From 065d2c77e49da74551d1ce247e1c2bf7ab0fa1e0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Nov 2013 11:50:03 +0000 Subject: Some formatting --- unix/tcl.m4 | 22 ++++++++++------------ win/tcl.m4 | 2 +- 2 files changed, 11 insertions(+), 13 deletions(-) diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 687866e..8c29334 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -111,9 +111,9 @@ AC_DEFUN([SC_PATH_TCLCONFIG], [ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do if test -f "$i/unix/tclConfig.sh" ; then - ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" - break - fi + ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" + break + fi done fi ]) @@ -271,11 +271,10 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ # # Results: # -# Subst the following vars: +# Substitutes the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE -# #------------------------------------------------------------------------ AC_DEFUN([SC_LOAD_TCLCONFIG], [ @@ -439,11 +438,11 @@ AC_DEFUN([SC_LOAD_TKCONFIG], [ # extension can't assume that an executable Tcl shell exists at # build time. # -# Arguments +# Arguments: # none # -# Results -# Subst's the following values: +# Results: +# Substitutes the following vars: # TCLSH_PROG #------------------------------------------------------------------------ @@ -484,11 +483,11 @@ AC_DEFUN([SC_PROG_TCLSH], [ # when running tests from an extension build directory. It is not # correct to use the TCLSH_PROG in cases like this. # -# Arguments +# Arguments: # none # -# Results -# Subst's the following values: +# Results: +# Substitutes the following values: # BUILD_TCLSH #------------------------------------------------------------------------ @@ -790,7 +789,6 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [ # # Defines the following vars: # HAVE_LANGINFO Triggers use of nl_langinfo if defined. -# #------------------------------------------------------------------------ AC_DEFUN([SC_ENABLE_LANGINFO], [ diff --git a/win/tcl.m4 b/win/tcl.m4 index 52c001f..625c329 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -247,7 +247,7 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ # # Results: # -# Subst the following vars: +# Substitutes the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE -- cgit v0.12 From 4043a96088465941703e7db82c538b1b4a8b7ee6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Nov 2013 11:20:32 +0000 Subject: Bug Fix: EnvTraceProc() MUST always return NULL to indicate success. --- generic/tclEnv.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 6a21947..7c49d44 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -614,7 +614,7 @@ EnvTraceProc( const char *value = TclGetEnv(name2, &valueString); if (value == NULL) { - return (char *) "no such variable"; + return NULL; } Tcl_SetVar2(interp, name1, name2, value, 0); Tcl_DStringFree(&valueString); -- cgit v0.12 From 3d8b62339c50842b052573c54a0654e3ddbb786d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Nov 2013 11:34:29 +0000 Subject: ... and don't break env-5.3 and env-5.5 test-cases. --- generic/tclEnv.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 7c49d44..8f51c1b 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -614,6 +614,7 @@ EnvTraceProc( const char *value = TclGetEnv(name2, &valueString); if (value == NULL) { + Tcl_UnsetVar2(interp, name1, name2, 0); return NULL; } Tcl_SetVar2(interp, name1, name2, value, 0); -- cgit v0.12 From 153e7dd76466be01fd76dac79e072291381af225 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Nov 2013 12:58:35 +0000 Subject: Fix env-5.1 test-case on Cygwin (and probably other platforms which don't have iso8859-1 as system-encoding) --- tests/env.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/env.test b/tests/env.test index 8115652..83d99e0 100644 --- a/tests/env.test +++ b/tests/env.test @@ -218,8 +218,8 @@ test env-4.5 {unsetting international environment variables} -setup { unset env(\ua7) getenv } -constraints {exec} -cleanup { - encoding system $sysenc unset env(\ub6) + encoding system $sysenc } -result {\u00b6=\u00a7} test env-5.0 {corner cases - set a value, it should exist} -body { -- cgit v0.12 From 26ecd5e21906b762f7c78747d9c29692575921ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Nov 2013 14:38:08 +0000 Subject: Starting with Windows 8 DSK, GetVersionExA is deprecated --- win/tclWin32Dll.c | 6 +++--- win/tclWinInit.c | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 2cb7d7c..e5e5202 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -432,11 +432,11 @@ void TclWinInit( HINSTANCE hInst) /* Library instance handle. */ { - OSVERSIONINFO os; + OSVERSIONINFOW os; hInstance = hInst; - os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - GetVersionEx(&os); + os.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + GetVersionExW(&os); platformId = os.dwPlatformId; /* diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 5baf020..81d762f 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -563,7 +563,7 @@ TclpSetVariables( SYSTEM_INFO info; OemId oemId; } sys; - OSVERSIONINFOA osInfo; + OSVERSIONINFOW osInfo; Tcl_DString ds; WCHAR szUserName[UNLEN+1]; DWORD cchUserNameLen = UNLEN; @@ -571,8 +571,8 @@ TclpSetVariables( Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); - GetVersionExA(&osInfo); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + GetVersionExW(&osInfo); GetSystemInfo(&sys.info); -- cgit v0.12 From 8422ebbd589e66f37e18e023a950a9d5eb23acd6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Nov 2013 16:04:43 +0000 Subject: Safer clean-up of environment variables: Do removal after insertions -> tcltest 2.3.7 --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 13 ++++++++----- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 13 insertions(+), 10 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 60a9485..c99ad2a 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.7 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index c30d2e4..d066a1b 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.6 + variable Version 2.3.7 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -2495,16 +2495,19 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { set changedEnv {} set removedEnv {} foreach index [array names ::env] { - if {![info exists originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { + if {[info exists originalEnv($index)]} { if {$::env($index) != $originalEnv($index)} { lappend changedEnv $index set ::env($index) $originalEnv($index) } } } + foreach index [array names ::env] { + if {![info exists originalEnv($index)]} { + lappend newEnv $index + unset ::env($index) + } + } foreach index [array names originalEnv] { if {![info exists ::env($index)]} { lappend removedEnv $index diff --git a/unix/Makefile.in b/unix/Makefile.in index 70d98c1..c7caf5b 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -782,8 +782,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.6 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.6.tm; + @echo "Installing package tcltest 2.3.7 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.7.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm; diff --git a/win/Makefile.in b/win/Makefile.in index e0b2f26..b962fb4 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -651,8 +651,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.6 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.6.tm; + @echo "Installing package tcltest 2.3.7 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.7.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From b89b27df4236a887798a52aadfb9f9641631b5dd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Nov 2013 09:18:04 +0000 Subject: The only relyable way of changing environment variables to uppercase (e.g. env(ComSpec) to env(COMSPEC)) is unsetting the old one first. Long-standing bug, exposed by [219226]. --- library/init.tcl | 72 ++++++++++++++++++++++----------------------- library/tcltest/tcltest.tcl | 11 ++----- 2 files changed, 39 insertions(+), 44 deletions(-) diff --git a/library/init.tcl b/library/init.tcl index 6b49fdf..38c6bb3 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -77,7 +77,7 @@ namespace eval tcl { # TIP #255 min and max functions namespace eval mathfunc { proc min {args} { - if {[llength $args] == 0} { + if {![llength $args]} { return -code error \ "too few arguments to math function \"min\"" } @@ -88,12 +88,12 @@ namespace eval tcl { if {[catch {expr {double($arg)}} err]} { return -code error $err } - if {$arg < $val} { set val $arg } + if {$arg < $val} {set val $arg} } return $val } proc max {args} { - if {[llength $args] == 0} { + if {![llength $args]} { return -code error \ "too few arguments to math function \"max\"" } @@ -104,7 +104,7 @@ namespace eval tcl { if {[catch {expr {double($arg)}} err]} { return -code error $err } - if {$arg > $val} { set val $arg } + if {$arg > $val} {set val $arg} } return $val } @@ -130,9 +130,9 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { switch -- $u { COMSPEC - PATH { - if {![info exists env($u)]} { - set env($u) $env($p) - } + set temp $env($p) + unset env($p) + set env($u) $temp trace add variable env($p) write \ [namespace code [list EnvTraceProc $p]] trace add variable env($u) write \ @@ -179,9 +179,9 @@ if {[interp issafe]} { -subcommands { add clicks format microseconds milliseconds scan seconds }] - + # Auto-loading stubs for 'clock.tcl' - + foreach cmd {add format scan} { proc ::tcl::clock::$cmd args { variable TclLibDir @@ -261,13 +261,13 @@ proc unknown args { # if {[info exists UnknownPending($name)]} { return -code error "self-referential recursion\ - in \"unknown\" for command \"$name\""; + in \"unknown\" for command \"$name\"" } - set UnknownPending($name) pending; + set UnknownPending($name) pending set ret [catch { auto_load $name [uplevel 1 {::namespace current}] } msg opts] - unset UnknownPending($name); + unset UnknownPending($name) if {$ret != 0} { dict append opts -errorinfo "\n (autoloading \"$name\")" return -options $opts $msg @@ -290,7 +290,7 @@ proc unknown args { if {$code == 1} { # # Compute stack trace contribution from the [uplevel]. - # Note the dependence on how Tcl_AddErrorInfo, etc. + # Note the dependence on how Tcl_AddErrorInfo, etc. # construct the stack trace. # set errInfo [dict get $opts -errorinfo] @@ -421,7 +421,7 @@ proc unknown args { # library file to create the procedure. Returns 1 if it successfully # loaded the procedure, 0 otherwise. # -# Arguments: +# Arguments: # cmd - Name of the command to find and load. # namespace (optional) The namespace where the command is being used - must be # a canonical namespace as returned [namespace current] @@ -445,7 +445,7 @@ proc auto_load {cmd {namespace {}}} { # info commands $name # Unfortunately, if the name has glob-magic chars in it like * # or [], it may not match. For our purposes here, a better - # route is to use + # route is to use # namespace which -command $name if {[namespace which -command $name] ne ""} { return 1 @@ -476,7 +476,7 @@ proc auto_load {cmd {namespace {}}} { # of available commands. Returns 1 if the index is loaded, and 0 if # the index is already loaded and up to date. # -# Arguments: +# Arguments: # None. proc auto_load_index {} { @@ -555,34 +555,34 @@ proc auto_qualify {cmd namespace} { # Before each return case we give an example of which category it is # with the following form : - # ( inputCmd, inputNameSpace) -> output + # (inputCmd, inputNameSpace) -> output if {[string match ::* $cmd]} { if {$n > 1} { - # ( ::foo::bar , * ) -> ::foo::bar + # (::foo::bar , *) -> ::foo::bar return [list $cmd] } else { - # ( ::global , * ) -> global + # (::global , *) -> global return [list [string range $cmd 2 end]] } } - + # Potentially returning 2 elements to try : # (if the current namespace is not the global one) if {$n == 0} { if {$namespace eq "::"} { - # ( nocolons , :: ) -> nocolons + # (nocolons , ::) -> nocolons return [list $cmd] } else { - # ( nocolons , ::sub ) -> ::sub::nocolons nocolons + # (nocolons , ::sub) -> ::sub::nocolons nocolons return [list ${namespace}::$cmd $cmd] } } elseif {$namespace eq "::"} { - # ( foo::bar , :: ) -> ::foo::bar + # (foo::bar , ::) -> ::foo::bar return [list ::$cmd] } else { - # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar + # (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar return [list ${namespace}::$cmd ::$cmd] } } @@ -624,13 +624,13 @@ proc auto_import {pattern} { # auto_execok -- # -# Returns string that indicates name of program to execute if +# Returns string that indicates name of program to execute if # name corresponds to a shell builtin or an executable in the -# Windows search path, or "" otherwise. Builds an associative -# array auto_execs that caches information about previous checks, +# Windows search path, or "" otherwise. Builds an associative +# array auto_execs that caches information about previous checks, # for speed. # -# Arguments: +# Arguments: # name - Name of a command. if {$tcl_platform(platform) eq "windows"} { @@ -685,7 +685,7 @@ proc auto_execok name { set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { - set windir $env(WINDIR) + set windir $env(WINDIR) } if {[info exists windir]} { if {$tcl_platform(os) eq "Windows NT"} { @@ -704,7 +704,7 @@ proc auto_execok name { unset -nocomplain checked foreach dir [split $path {;}] { # Skip already checked directories - if {[info exists checked($dir)] || ($dir eq {})} { + if {[info exists checked($dir)] || ($dir eq "")} { continue } set checked($dir) {} @@ -753,13 +753,13 @@ proc auto_execok name { # This procedure is called by Tcl's core when attempts to call the # filesystem's copydirectory function fail. The semantics of the call # are that 'dest' does not yet exist, i.e. dest should become the exact -# image of src. If dest does exist, we throw an error. -# +# image of src. If dest does exist, we throw an error. +# # Note that making changes to this procedure can change the results # of running Tcl's tests. # -# Arguments: -# action - "renaming" or "copying" +# Arguments: +# action - "renaming" or "copying" # src - source directory # dest - destination directory proc tcl::CopyDirectory {action src dest} { @@ -787,7 +787,7 @@ proc tcl::CopyDirectory {action src dest} { # exists, then we should only call this function if -force # is true, which means we just want to over-write. So, # the following code is now commented out. - # + # # return -code error "error $action \"$src\" to\ # \"$dest\": file already exists" } else { @@ -820,7 +820,7 @@ proc tcl::CopyDirectory {action src dest} { # Have to be careful to capture both visible and hidden files. # We will also be more generous to the file system and not # assume the hidden and non-hidden lists are non-overlapping. - # + # # On Unix 'hidden' files begin with '.'. On other platforms # or filesystems hidden files may have other interpretations. set filelist [concat [glob -nocomplain -directory $src *] \ diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d066a1b..4b94312 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2495,14 +2495,6 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { set changedEnv {} set removedEnv {} foreach index [array names ::env] { - if {[info exists originalEnv($index)]} { - if {$::env($index) != $originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $originalEnv($index) - } - } - } - foreach index [array names ::env] { if {![info exists originalEnv($index)]} { lappend newEnv $index unset ::env($index) @@ -2512,6 +2504,9 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { if {![info exists ::env($index)]} { lappend removedEnv $index set ::env($index) $originalEnv($index) + } elseif {$::env($index) ne $originalEnv($index)} { + lappend changedEnv $index + set ::env($index) $originalEnv($index) } } if {[llength $newEnv] > 0} { -- cgit v0.12 From 5709ed46ce9b53ea3d2f46076b8e07cc5324fa55 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Nov 2013 11:43:00 +0000 Subject: Add support for Windows 8.1: See [http://msdn.microsoft.com/en-us/library/windows/desktop/dn302074.aspx] --- win/configure | 20 ++++++++++++++++++-- win/configure.in | 15 ++++++++++++++- win/tclsh.exe.manifest.in | 33 +++++++++++++++++++++++++++++++++ win/tclsh.rc | 13 +++++++++++++ 4 files changed, 78 insertions(+), 3 deletions(-) create mode 100644 win/tclsh.exe.manifest.in diff --git a/win/configure b/win/configure index a997ac9..cec352b 100755 --- a/win/configure +++ b/win/configure @@ -309,7 +309,7 @@ ac_includes_default="\ # include #endif" -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_WIN_VERSION MACHINE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. @@ -4821,6 +4821,19 @@ else TCL_PACKAGE_PATH="${prefix}/lib" fi +# The tclsh.exe.manifest requires these +# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs +# the release level, and must account for interim release versioning +case "$TCL_PATCH_LEVEL" in + *a*) TCL_RELEASE_LEVEL=0 ;; + *b*) TCL_RELEASE_LEVEL=1 ;; + *) TCL_RELEASE_LEVEL=2 ;; +esac +TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" + +# X86|AMD64|IA64 for manifest + + @@ -4909,7 +4922,7 @@ fi - ac_config_files="$ac_config_files Makefile tclConfig.sh tcl.hpj" + ac_config_files="$ac_config_files Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure @@ -5463,6 +5476,7 @@ do "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; "tclConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;; "tcl.hpj" ) CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;; + "tclsh.exe.manifest" ) CONFIG_FILES="$CONFIG_FILES tclsh.exe.manifest" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} { (exit 1); exit 1; }; };; @@ -5573,6 +5587,8 @@ s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t s,@VC_MANIFEST_EMBED_DLL@,$VC_MANIFEST_EMBED_DLL,;t t s,@VC_MANIFEST_EMBED_EXE@,$VC_MANIFEST_EMBED_EXE,;t t +s,@TCL_WIN_VERSION@,$TCL_WIN_VERSION,;t t +s,@MACHINE@,$MACHINE,;t t s,@TCL_VERSION@,$TCL_VERSION,;t t s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t diff --git a/win/configure.in b/win/configure.in index 8b181f8..cde3ab4 100644 --- a/win/configure.in +++ b/win/configure.in @@ -248,6 +248,19 @@ else TCL_PACKAGE_PATH="${prefix}/lib" fi +# The tclsh.exe.manifest requires these +# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs +# the release level, and must account for interim release versioning +case "$TCL_PATCH_LEVEL" in + *a*) TCL_RELEASE_LEVEL=0 ;; + *b*) TCL_RELEASE_LEVEL=1 ;; + *) TCL_RELEASE_LEVEL=2 ;; +esac +TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" +AC_SUBST(TCL_WIN_VERSION) +# X86|AMD64|IA64 for manifest +AC_SUBST(MACHINE) + AC_SUBST(TCL_VERSION) AC_SUBST(TCL_MAJOR_VERSION) AC_SUBST(TCL_MINOR_VERSION) @@ -336,7 +349,7 @@ AC_SUBST(RC_DEFINE) AC_SUBST(RC_DEFINES) AC_SUBST(RES) -AC_OUTPUT(Makefile tclConfig.sh tcl.hpj) +AC_OUTPUT(Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest) dnl Local Variables: dnl mode: autoconf; diff --git a/win/tclsh.exe.manifest.in b/win/tclsh.exe.manifest.in new file mode 100644 index 0000000..aaa34e1 --- /dev/null +++ b/win/tclsh.exe.manifest.in @@ -0,0 +1,33 @@ + + + + Tcl command line shell (tclsh) + + + + + + + + + + + + + + + + + + + + diff --git a/win/tclsh.rc b/win/tclsh.rc index 16eaf83..161da50 100644 --- a/win/tclsh.rc +++ b/win/tclsh.rc @@ -1,3 +1,4 @@ +// // Version Resource Script // @@ -67,3 +68,15 @@ END // tclsh ICON DISCARDABLE "tclsh.ico" + +// +// This is needed for Windows 8.1 onwards. +// + +#ifndef RT_MANIFEST +#define RT_MANIFEST 24 +#endif +#ifndef CREATEPROCESS_MANIFEST_RESOURCE_ID +#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 +#endif +CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "tclsh.exe.manifest" -- cgit v0.12 From 6a67104caf0fc1639d28655d981bc0cc69d34770 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Nov 2013 16:20:01 +0000 Subject: Modify makefile.vc for Windows 8.1 support --- win/makefile.vc | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index d9570b9..4466439 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -899,6 +899,12 @@ $(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? +$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in + @nmakehlp -s << $** >$@ +@MACHINE@ $(MACHINE:IX86=X86) +@TCL_WIN_VERSION@ $(TCL_DOTVERSION).0.0 +<< + #--------------------------------------------------------------------- # Generate the source dependencies. Having dependency rules will # improve incremental build accuracy without having to resort to a @@ -958,12 +964,14 @@ $< << {$(WINDIR)}.rc{$(TMP_DIR)}.res: - $(rc32) -fo $@ -r -i "$(GENERICDIR)" \ + $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ -d DEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ -d TCL_THREADS=$(TCL_THREADS) \ -d STATIC_BUILD=$(STATIC_BUILD) \ $< +$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest + .SUFFIXES: .SUFFIXES:.c .rc -- cgit v0.12 From cec233a8882dbc9c5eab369b88cef6bc32675e07 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Nov 2013 13:16:21 +0000 Subject: Cygwin: Fix conflicting definition with _mingw_stat64.h, if included together with --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index eeff36e..31960ec 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -422,7 +422,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; typedef struct _stat32i64 Tcl_StatBuf; # endif /* _MSC_VER < 1400 */ #elif defined(__CYGWIN__) - typedef struct _stat32i64 { + typedef struct { dev_t st_dev; unsigned short st_ino; unsigned short st_mode; -- cgit v0.12 From 0e5086f719695cdd73a674a6351811f525df3d21 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Nov 2013 13:21:52 +0000 Subject: revert accidental part of previous commit --- generic/regcustom.h | 4 ---- generic/regex.h | 4 ---- 2 files changed, 8 deletions(-) diff --git a/generic/regcustom.h b/generic/regcustom.h index d907ca7..1c970ea 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -74,11 +74,7 @@ #endif /* Interface types */ #define __REG_WIDE_T Tcl_UniChar -#ifdef __CYGWIN__ -#define __REG_REGOFF_T int /* Not really right, but good enough... */ -#else #define __REG_REGOFF_T long /* Not really right, but good enough... */ -#endif #define __REG_VOID_T void #define __REG_CONST const /* Names and declarations */ diff --git a/generic/regex.h b/generic/regex.h index 4422f2a..9466fbb 100644 --- a/generic/regex.h +++ b/generic/regex.h @@ -106,11 +106,7 @@ extern "C" { #endif /* interface types */ #define __REG_WIDE_T Tcl_UniChar -#ifdef __CYGWIN__ -#define __REG_REGOFF_T int /* not really right, but good enough... */ -#else #define __REG_REGOFF_T long /* not really right, but good enough... */ -#endif #define __REG_VOID_T void #define __REG_CONST const /* names and declarations */ -- cgit v0.12 From 01b92615b5fb4025779590ceff95fe4e562d0d81 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 24 Nov 2013 18:34:16 +0000 Subject: [a122627849] Improve stack trace from parray on not-array. --- library/parray.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/parray.tcl b/library/parray.tcl index 3ce9817..a9c2cb1 100644 --- a/library/parray.tcl +++ b/library/parray.tcl @@ -11,7 +11,7 @@ proc parray {a {pattern *}} { upvar 1 $a array if {![array exists array]} { - error "\"$a\" isn't an array" + return -code error "\"$a\" isn't an array" } set maxl 0 set names [lsort [array names array $pattern]] -- cgit v0.12 From fe466d7e44e868229e27ec19e88092f804b18e08 Mon Sep 17 00:00:00 2001 From: mig Date: Thu, 5 Dec 2013 15:15:23 +0000 Subject: New compiler and bytecodes for foreach and lmap: 70% faster * speed as measured by http://wiki.tcl.tk/39021: runs in <1/3 the time * still need to adapt array-set to use this * assemble.test-16.5 or 16.6 bombs in a purify/symbols build (?) * removing the old opcodes would force recompilation of old .tbc files or adaptation of tbcload --- generic/tcl.h | 4 ++ generic/tclCompCmds.c | 131 ++++++++++----------------------------- generic/tclCompile.c | 10 +++ generic/tclCompile.h | 12 +++- generic/tclExecute.c | 168 +++++++++++++++++++++++++++++++++++++++++++++++++- 5 files changed, 220 insertions(+), 105 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 4bf81cc..aab299e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -848,6 +848,10 @@ typedef struct Tcl_Obj { void *ptr; unsigned long value; } ptrAndLongRep; + struct { + long int1; + long int2; + } twoIntValue; } internalRep; } Tcl_Obj; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9c43bfe..e934d92 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2469,18 +2469,12 @@ CompileEachloopCmd( ForeachInfo *infoPtr; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ - int firstValueTemp; /* Index of the first temp var in the frame - * used to point to a value list. */ - int loopCtTemp; /* Index of temp var holding the loop's - * iteration count. */ int collectVar = -1; /* Index of temp var holding the result var * index. */ - + Tcl_Token *tokenPtr, *bodyTokenPtr; - unsigned char *jumpPc; - JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range; - int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; + int jumpBackOffset, infoIndex, range; + int numWords, numLists, numVars, loopIndex, i, j, code; DefineLineInformation; /* TIP #280 */ /* @@ -2588,6 +2582,10 @@ CompileEachloopCmd( loopIndex++; } + /* + * We will compile the foreach command. + */ + if (collect == TCL_EACH_COLLECT) { collectVar = AnonymousLocal(envPtr); if (collectVar < 0) { @@ -2595,25 +2593,7 @@ CompileEachloopCmd( } } - /* - * We will compile the foreach command. Reserve (numLists + 1) temporary - * variables: - * - numLists temps to hold each value list - * - 1 temp for the loop counter (index of next element in each list) - * - * At this time we don't try to reuse temporaries; if there are two - * nonoverlapping foreach loops, they don't share any temps. - */ - code = TCL_OK; - firstValueTemp = -1; - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - tempVar = AnonymousLocal(envPtr); - if (loopIndex == 0) { - firstValueTemp = tempVar; - } - } - loopCtTemp = AnonymousLocal(envPtr); /* * Create and initialize the ForeachInfo and ForeachVarList data @@ -2624,8 +2604,8 @@ CompileEachloopCmd( infoPtr = ckalloc(sizeof(ForeachInfo) + numLists * sizeof(ForeachVarList *)); infoPtr->numLists = numLists; - infoPtr->firstValueTemp = firstValueTemp; - infoPtr->loopCtTemp = loopCtTemp; + infoPtr->firstValueTemp = collect; + infoPtr->loopCtTemp = 0; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; @@ -2645,25 +2625,14 @@ CompileEachloopCmd( infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); /* - * Create an exception record to handle [break] and [continue]. + * Evaluate each value list and leave it on stack. */ - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - - /* - * Evaluate then store each value list in the associated temporary. - */ - - loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { CompileWord(envPtr, tokenPtr, interp, i); - tempVar = (firstValueTemp + loopIndex); - Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - loopIndex++; } } @@ -2677,81 +2646,43 @@ CompileEachloopCmd( TclEmitOpcode( INST_POP, envPtr); } - /* - * Initialize the temporary var that holds the count of loop iterations. - */ - - TclEmitInstInt4( INST_FOREACH_START4, infoIndex, envPtr); - - /* - * Top of loop code: assign each loop variable and check whether - * to terminate the loop. - */ - - ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitInstInt4( INST_FOREACH_STEP4, infoIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - + TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + /* * Inline compile the loop body. */ + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeStarts(envPtr, range); BODY(bodyTokenPtr, numWords - 1); ExceptionRangeEnds(envPtr, range); - + if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); } TclEmitOpcode( INST_POP, envPtr); /* - * Jump back to the test at the top of the loop. Generate a 4 byte jump if - * the distance to the test is > 120 bytes. This is conservative and - * ensures that we won't have to replace this jump if we later need to - * replace the ifFalse jump with a 4 byte jump. + * Bottom of loop code: assign each loop variable and check whether + * to terminate the loop. Set the loop's break target. */ - jumpBackOffset = CurrentOffset(envPtr); - jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); - } - - /* - * Fix the target of the jump after the foreach_step test. - */ - - if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) { - /* - * Update the loop body's starting PC offset since it moved down. - */ - - envPtr->exceptArrayPtr[range].codeOffset += 3; - - /* - * Update the jump back to the test at the top of the loop since it - * also moved down 3 bytes. - */ - - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - jumpBackDist += 3; - if (jumpBackDist > 120) { - TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); - } else { - TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); - } - } + ExceptionRangeTarget(envPtr, range, continueOffset); + TclEmitOpcode(INST_FOREACH_STEP, envPtr); + ExceptionRangeTarget(envPtr, range, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, range); + TclEmitOpcode(INST_FOREACH_END, envPtr); + TclAdjustStackDepth(-(numLists+2), envPtr); /* - * Set the loop's break target. + * Set the jumpback distance from INST_FOREACH_STEP to the start of the + * body's code */ - - ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); + + jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - + envPtr->exceptArrayPtr[range].codeOffset; + infoPtr->loopCtTemp = -jumpBackOffset; /* * The command's result is an empty string if not collecting, or the @@ -2765,8 +2696,8 @@ CompileEachloopCmd( } else { PushStringLiteral(envPtr, ""); } - - done: + + done: for (loopIndex = 0; loopIndex < numLists; loopIndex++) { if (varvList[loopIndex] != NULL) { ckfree(varvList[loopIndex]); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 3c8e4ef..7cd9796 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -545,6 +545,16 @@ InstructionDesc const tclInstructionTable[] = { /* Drops an element from the auxiliary stack, popping stack elements * until the matching stack depth is reached. */ + /* New foreach implementation */ + {"foreach_start", 5, +2, 1, {OPERAND_AUX4}}, + /* Initialize execution of a foreach loop. Operand is aux data index + * of the ForeachInfo structure for the foreach command. It pushes 2 + * elements which hold runtime params for foreach_step, they are later + * dropped by foreach_end together with the value lists. */ + {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, + /* "Step" or begin next iteration of foreach loop. */ + {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a39e0f1..c4e6222 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -586,8 +586,8 @@ typedef struct ByteCode { #define INST_CONTINUE 66 /* Opcodes 67 to 68 */ -#define INST_FOREACH_START4 67 -#define INST_FOREACH_STEP4 68 +#define INST_FOREACH_START4 67 /* DEPRECATED */ +#define INST_FOREACH_STEP4 68 /* DEPRECATED */ /* Opcodes 69 to 72 */ #define INST_BEGIN_CATCH4 69 @@ -768,8 +768,14 @@ typedef struct ByteCode { #define INST_EXPAND_DROP 165 +/* New foreach implementation */ + +#define INST_FOREACH_START 166 +#define INST_FOREACH_STEP 167 +#define INST_FOREACH_END 168 + /* The last opcode */ -#define LAST_INST_OPCODE 165 +#define LAST_INST_OPCODE 168 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d3c1227..32b64a2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6029,7 +6029,7 @@ TEBCresume( int varIndex, valIndex, continueLoop, j, iterTmpIndex; long i; - case INST_FOREACH_START4: + case INST_FOREACH_START4: /* DEPRECATED */ /* * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. @@ -6062,7 +6062,7 @@ TEBCresume( NEXT_INST_F(5, 0, 0); #endif - case INST_FOREACH_STEP4: + case INST_FOREACH_STEP4: /* DEPRECATED */ /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. @@ -6180,6 +6180,170 @@ TEBCresume( } else { NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); } + + } + { + ForeachInfo *infoPtr; + Tcl_Obj *listPtr, **elements, *tmpPtr; + ForeachVarList *varListPtr; + int numLists, iterMax, listLen, numVars; + int iterTmp, iterNum, listTmpDepth; + int varIndex, valIndex, j; + long i; + + case INST_FOREACH_START: + /* + * Initialize the data for the looping construct, pushing the + * corresponding Tcl_Objs to the stack. + */ + + + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + numLists = infoPtr->numLists; + + /* + * Compute the number of iterations that will be run: iterMax + */ + + iterMax = 0; + listTmpDepth = numLists-1; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + listPtr = OBJ_AT_DEPTH(listTmpDepth); + if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { + TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", + opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + goto gotError; + } + if (Tcl_IsShared(listPtr)) { + objPtr = TclListObjCopy(NULL, listPtr); + Tcl_IncrRefCount(objPtr); + Tcl_DecrRefCount(listPtr); + OBJ_AT_DEPTH(listTmpDepth) = objPtr; + } + iterTmp = (listLen + (numVars - 1))/numVars; + if (iterTmp > iterMax) { + iterMax = iterTmp; + } + listTmpDepth--; + } + + /* + * Store the iterNum and iterMax in a single Tcl_Obj; we keep a + * nul-string obj with the pointer stored in the ptrValue so that the + * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but + * it will never leave this scope and is read-only. + */ + + TclNewObj(tmpPtr); + tmpPtr->internalRep.twoIntValue.int1 = 0; + tmpPtr->internalRep.twoIntValue.int2 = iterMax; + PUSH_OBJECT(tmpPtr); /* iterCounts object */ + + /* + * Store a pointer to the ForeachInfo struct; same dirty trick + * as above + */ + + TclNewObj(tmpPtr); + tmpPtr->internalRep.otherValuePtr = infoPtr; + PUSH_OBJECT(tmpPtr); /* infoPtr object */ + + /* + * Jump directly to the INST_FOREACH_STEP instruction; the C code just + * falls through. + */ + + pc += 5 - infoPtr->loopCtTemp; + + case INST_FOREACH_STEP: + /* + * "Step" a foreach loop (i.e., begin its next iteration) by assigning + * the next value list element to each loop var. + */ + + tmpPtr = OBJ_AT_TOS; + infoPtr = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + + tmpPtr = OBJ_AT_DEPTH(1); + iterNum = tmpPtr->internalRep.twoIntValue.int1; + iterMax = tmpPtr->internalRep.twoIntValue.int2; + + /* + * If some list still has a remaining list element iterate one more + * time. Assign to var the next element from its value list. + */ + + if (iterNum < iterMax) { + /* + * Set the variables and jump back to run the body + */ + + tmpPtr->internalRep.twoIntValue.int1 = iterNum + 1; + + listTmpDepth = numLists + 1; + + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listPtr = OBJ_AT_DEPTH(listTmpDepth); + TclListObjGetElements(interp, listPtr, &listLen, &elements); + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + if (valIndex >= listLen) { + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + varPtr = LOCAL(varIndex); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectWritable(varPtr)) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { + DECACHE_STACK_INFO(); + if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + CACHE_STACK_INFO(); + TRACE_WITH_OBJ(( + "%u => ERROR init. index temp %d: ", + opnd,varIndex), Tcl_GetObjResult(interp)); + goto gotError; + } + CACHE_STACK_INFO(); + } + valIndex++; + } + listTmpDepth--; + } + NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); + } + + /* + * FALL THROUGH + */ + pc++; + + case INST_FOREACH_END: + tmpPtr = OBJ_AT_TOS; + infoPtr = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + NEXT_INST_V(1, numLists+2, 0); } case INST_BEGIN_CATCH4: -- cgit v0.12 From d4c2352c272018c182366cf571aeaaff813456e7 Mon Sep 17 00:00:00 2001 From: mig Date: Thu, 5 Dec 2013 16:01:16 +0000 Subject: add comments on field "misuse" --- generic/tclCompCmds.c | 2 +- generic/tclExecute.c | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index e934d92..78c6c5a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2677,7 +2677,7 @@ CompileEachloopCmd( /* * Set the jumpback distance from INST_FOREACH_STEP to the start of the - * body's code + * body's code. Misuse loopCtTemp for storing the jump size. */ jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 32b64a2..191a897 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6331,6 +6331,7 @@ TEBCresume( } listTmpDepth--; } + /* loopCtTemp being 'misused' for storing the jump size */ NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); } -- cgit v0.12 From b195b458489ac87c42d50ed3f8f8e529208ecda7 Mon Sep 17 00:00:00 2001 From: mig Date: Thu, 5 Dec 2013 17:18:54 +0000 Subject: add comments on INST_FOREACH_* --- generic/tclExecute.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 191a897..fe05b30 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6259,6 +6259,7 @@ TEBCresume( pc += 5 - infoPtr->loopCtTemp; case INST_FOREACH_STEP: + /* THIS INSTRUCTION IS ONLY CALLED AS A CONTINUE TARGET */ /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. @@ -6341,6 +6342,7 @@ TEBCresume( pc++; case INST_FOREACH_END: + /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */ tmpPtr = OBJ_AT_TOS; infoPtr = tmpPtr->internalRep.otherValuePtr; numLists = infoPtr->numLists; -- cgit v0.12 From a92abd2be9e129d4020815965e516a8361742dec Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Dec 2013 20:45:45 +0000 Subject: Draft fix for Bug 0b874c344d. Includes test. --- generic/tclCmdIL.c | 60 ++++++++++++++++++++++++++++++++++++++++++++++++---- tests/coroutine.test | 3 +++ 2 files changed, 59 insertions(+), 4 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index fa4ead4..57434c1 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -104,6 +104,8 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ +static CmdFrame * CmdFrameChain(CoroutineData *corPtr); +static void CmdFrameUnchain(CoroutineData *corPtr); static int DictionaryCompare(const char *left, const char *right); static int IfConditionCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -1167,20 +1169,22 @@ InfoFrameCmd( */ CmdFrame *lastPtr = NULL; + CmdFrame *tailPtr = CmdFrameChain(corPtr); + int offset = tailPtr ? tailPtr->level : 0; runPtr = iPtr->cmdFramePtr; /* TODO - deal with overflow */ - topLevel += corPtr->caller.cmdFramePtr->level; + topLevel += offset; while (runPtr) { - runPtr->level += corPtr->caller.cmdFramePtr->level; + runPtr->level += offset; lastPtr = runPtr; runPtr = runPtr->nextPtr; } if (lastPtr) { - lastPtr->nextPtr = corPtr->caller.cmdFramePtr; + lastPtr->nextPtr = tailPtr; } else { - iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr; + iPtr->cmdFramePtr = tailPtr; } } @@ -1244,10 +1248,58 @@ InfoFrameCmd( runPtr->level = 1; runPtr->nextPtr = NULL; } + CmdFrameUnchain(corPtr); } return code; } + +static void +CmdFrameUnchain( + CoroutineData *corPtr) +{ + if (corPtr->callerEEPtr->corPtr) { + CmdFrame *endPtr = corPtr->callerEEPtr->corPtr->caller.cmdFramePtr; + + if (corPtr->caller.cmdFramePtr == endPtr) { + corPtr->caller.cmdFramePtr = NULL; + } else { + CmdFrame *runPtr = corPtr->caller.cmdFramePtr; + + while (runPtr->nextPtr != endPtr) { + runPtr->level -= endPtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; + } + CmdFrameUnchain(corPtr->callerEEPtr->corPtr); + } +} + +static CmdFrame * +CmdFrameChain( + CoroutineData *corPtr) +{ + if (corPtr->callerEEPtr->corPtr) { + CmdFrame *tailPtr = CmdFrameChain(corPtr->callerEEPtr->corPtr); + CmdFrame *lastPtr = NULL; + CmdFrame *runPtr = corPtr->caller.cmdFramePtr; + int offset = tailPtr ? tailPtr->level : 0; + + while (runPtr) { + runPtr->level += offset; + lastPtr = runPtr; + runPtr = runPtr->nextPtr; + } + if (lastPtr) { + lastPtr->nextPtr = tailPtr; + } else { + corPtr->caller.cmdFramePtr = tailPtr; + } + } + return corPtr->caller.cmdFramePtr; +} /* *---------------------------------------------------------------------- diff --git a/tests/coroutine.test b/tests/coroutine.test index 03c63ad..a360fd5 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -342,6 +342,9 @@ test coroutine-3.6 {info frame, bug #2910094} -setup { rename stack {} rename a {} } -result {} +test coroutine-3.7 {bug 0b874c344d} { + dict get [coroutine X coroutine Y info frame 0] cmd +} {coroutine X coroutine Y info frame 0} test coroutine-4.1 {bug #2093188} -setup { proc foo {} { -- cgit v0.12 From 74ce54a69d5333c4bb4bb621e9e245d9c153ad9e Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 6 Dec 2013 00:02:16 +0000 Subject: tighter mem management --- generic/tclCompCmds.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 78c6c5a..da14af1 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2602,16 +2602,14 @@ CompileEachloopCmd( */ infoPtr = ckalloc(sizeof(ForeachInfo) - + numLists * sizeof(ForeachVarList *)); + + (numLists - 1) * sizeof(ForeachVarList *)); infoPtr->numLists = numLists; - infoPtr->firstValueTemp = collect; - infoPtr->loopCtTemp = 0; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; numVars = varcList[loopIndex]; varListPtr = ckalloc(sizeof(ForeachVarList) - + numVars * sizeof(int)); + + (numVars - 1) * sizeof(int)); varListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { const char *varName = varvList[loopIndex][j]; -- cgit v0.12 From e839a385d8c656b6a1a68a21856d89711ef0a9e5 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 6 Dec 2013 00:16:07 +0000 Subject: tighter mem management in array-set compiler --- generic/tclCompCmds.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index da14af1..73b1ec3 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -323,11 +323,11 @@ TclCompileArraySetCmd( keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); - infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); + infoPtr = ckalloc(sizeof(ForeachInfo)); infoPtr->numLists = 1; infoPtr->firstValueTemp = dataVar; infoPtr->loopCtTemp = iterVar; - infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int)); + infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; -- cgit v0.12 From bd2bdc19042808b788624ce902dec3bdc193bd1b Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 6 Dec 2013 01:07:10 +0000 Subject: adapted the array-set compiler to use the new foreach opcodes --- generic/tclCompCmds.c | 83 +++++++++++++++++++-------------------------------- generic/tclExecute.c | 1 - 2 files changed, 31 insertions(+), 53 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 73b1ec3..b8b2605 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -245,8 +245,8 @@ TclCompileArraySetCmd( Tcl_Token *varTokenPtr, *dataTokenPtr; int isScalar, localIndex, code = TCL_OK; int isDataLiteral, isDataValid, isDataEven, len; - int dataVar, iterVar, keyVar, valVar, infoIndex; - int back, fwd, offsetBack, offsetFwd; + int keyVar, valVar, infoIndex; + int fwd, offsetBack, offsetFwd; Tcl_Obj *literalObj; ForeachInfo *infoPtr; @@ -290,6 +290,7 @@ TclCompileArraySetCmd( code = TCL_ERROR; goto done; } + /* * Special case: literal empty value argument is just an "ensure array" * operation. @@ -314,19 +315,28 @@ TclCompileArraySetCmd( goto done; } + if (localIndex < 0) { + /* + * a non-local variable: upvar from a local one! This consumes the + * variable name that was left at stacktop. + */ + + localIndex = AnonymousLocal(envPtr); + PushStringLiteral(envPtr, "0"); + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); + TclEmitOpcode(INST_POP, envPtr); + } + /* * Prepare for the internal foreach. */ - dataVar = AnonymousLocal(envPtr); - iterVar = AnonymousLocal(envPtr); keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); infoPtr = ckalloc(sizeof(ForeachInfo)); infoPtr->numLists = 1; - infoPtr->firstValueTemp = dataVar; - infoPtr->loopCtTemp = iterVar; infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; @@ -360,54 +370,23 @@ TclCompileArraySetCmd( fwd = CurrentOffset(envPtr) - offsetFwd; TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); } - Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - back = offsetBack - CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, back, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - back = offsetBack - CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, back, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - TclEmitOpcode( INST_POP, envPtr); - } - if (!isDataLiteral) { - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( dataVar, envPtr); - } + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + offsetBack = CurrentOffset(envPtr); + Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ + TclEmitOpcode( INST_FOREACH_STEP, envPtr); + TclEmitOpcode( INST_FOREACH_END, envPtr); + TclAdjustStackDepth(-3, envPtr); PushStringLiteral(envPtr, ""); - done: + + done: Tcl_DecrRefCount(literalObj); return code; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fe05b30..a831cd6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6259,7 +6259,6 @@ TEBCresume( pc += 5 - infoPtr->loopCtTemp; case INST_FOREACH_STEP: - /* THIS INSTRUCTION IS ONLY CALLED AS A CONTINUE TARGET */ /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. -- cgit v0.12 From fd4b83758661b1cfe4a498d02aae1d1ce63a6292 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 6 Dec 2013 09:28:45 +0000 Subject: Stop printing undefined values in disassembled code. --- generic/tclCompCmds.c | 42 +++++++++++++++++++++++++++++++++++++++++- generic/tclCompile.h | 1 + generic/tclExecute.c | 17 ++++++++--------- 3 files changed, 50 insertions(+), 10 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index b8b2605..bdab2ff 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -31,6 +31,9 @@ static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void PrintNewForeachInfo(ClientData clientData, + Tcl_Obj *appendObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); @@ -49,6 +52,13 @@ const AuxDataType tclForeachInfoType = { PrintForeachInfo /* printProc */ }; +const AuxDataType tclNewForeachInfoType = { + "NewForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo, /* freeProc */ + PrintNewForeachInfo /* printProc */ +}; + const AuxDataType tclDictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ @@ -2599,7 +2609,7 @@ CompileEachloopCmd( } infoPtr->varLists[loopIndex] = varListPtr; } - infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); + infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr); /* * Evaluate each value list and leave it on stack. @@ -2828,6 +2838,36 @@ PrintForeachInfo( Tcl_AppendToObj(appendObj, "]", -1); } } + +static void +PrintNewForeachInfo( + ClientData clientData, + Tcl_Obj *appendObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + + Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", + infoPtr->loopCtTemp); + for (i=0 ; inumLists ; i++) { + if (i) { + Tcl_AppendToObj(appendObj, ",", -1); + } + Tcl_AppendToObj(appendObj, "[", -1); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; jnumVars ; j++) { + if (j) { + Tcl_AppendToObj(appendObj, ",", -1); + } + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); + } + Tcl_AppendToObj(appendObj, "]", -1); + } +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c4e6222..8b1724b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -908,6 +908,7 @@ typedef struct ForeachInfo { } ForeachInfo; MODULE_SCOPE const AuxDataType tclForeachInfoType; +MODULE_SCOPE const AuxDataType tclNewForeachInfoType; #define FOREACHINFO(envPtr, index) \ ((ForeachInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a831cd6..f496fe7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6197,7 +6197,6 @@ TEBCresume( * corresponding Tcl_Objs to the stack. */ - opnd = TclGetUInt4AtPtr(pc+1); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; @@ -6229,7 +6228,7 @@ TEBCresume( } listTmpDepth--; } - + /* * Store the iterNum and iterMax in a single Tcl_Obj; we keep a * nul-string obj with the pointer stored in the ptrValue so that the @@ -6241,12 +6240,12 @@ TEBCresume( tmpPtr->internalRep.twoIntValue.int1 = 0; tmpPtr->internalRep.twoIntValue.int2 = iterMax; PUSH_OBJECT(tmpPtr); /* iterCounts object */ - + /* * Store a pointer to the ForeachInfo struct; same dirty trick - * as above + * as above */ - + TclNewObj(tmpPtr); tmpPtr->internalRep.otherValuePtr = infoPtr; PUSH_OBJECT(tmpPtr); /* infoPtr object */ @@ -6254,10 +6253,10 @@ TEBCresume( /* * Jump directly to the INST_FOREACH_STEP instruction; the C code just * falls through. - */ + */ pc += 5 - infoPtr->loopCtTemp; - + case INST_FOREACH_STEP: /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning @@ -6276,14 +6275,14 @@ TEBCresume( * If some list still has a remaining list element iterate one more * time. Assign to var the next element from its value list. */ - + if (iterNum < iterMax) { /* * Set the variables and jump back to run the body */ tmpPtr->internalRep.twoIntValue.int1 = iterNum + 1; - + listTmpDepth = numLists + 1; for (i = 0; i < numLists; i++) { -- cgit v0.12 From 43f960c3dea76f400a1142b3fcc800f94f998f54 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 6 Dec 2013 10:04:48 +0000 Subject: Introducing a new union member in Tcl_Obj is not a good idea in a patch release, especially using "long". Better allow iterNum and iterMax to grow to ssize_t (or size_t) in Tcl 9 (or 8.x, why not?). Usage of "long" in public API causes interoperability problems between Cygwin64 and Win64 (probably no-one cares except me). --- generic/tcl.h | 4 ---- generic/tclExecute.c | 10 +++++----- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index aab299e..4bf81cc 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -848,10 +848,6 @@ typedef struct Tcl_Obj { void *ptr; unsigned long value; } ptrAndLongRep; - struct { - long int1; - long int2; - } twoIntValue; } internalRep; } Tcl_Obj; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f496fe7..c3f5372 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6237,8 +6237,8 @@ TEBCresume( */ TclNewObj(tmpPtr); - tmpPtr->internalRep.twoIntValue.int1 = 0; - tmpPtr->internalRep.twoIntValue.int2 = iterMax; + tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; + tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax); PUSH_OBJECT(tmpPtr); /* iterCounts object */ /* @@ -6268,8 +6268,8 @@ TEBCresume( numLists = infoPtr->numLists; tmpPtr = OBJ_AT_DEPTH(1); - iterNum = tmpPtr->internalRep.twoIntValue.int1; - iterMax = tmpPtr->internalRep.twoIntValue.int2; + iterNum = INT2PTR(tmpPtr->internalRep.twoPtrValue.ptr1); + iterMax = INT2PTR(tmpPtr->internalRep.twoPtrValue.ptr2); /* * If some list still has a remaining list element iterate one more @@ -6281,7 +6281,7 @@ TEBCresume( * Set the variables and jump back to run the body */ - tmpPtr->internalRep.twoIntValue.int1 = iterNum + 1; + tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1); listTmpDepth = numLists + 1; -- cgit v0.12 From b737753dbb6a18de6429e4d0cd3547ed2fcdf4f6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 6 Dec 2013 10:17:58 +0000 Subject: Oops, wrong macro. --- generic/tclExecute.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c3f5372..b6d8841 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6268,8 +6268,8 @@ TEBCresume( numLists = infoPtr->numLists; tmpPtr = OBJ_AT_DEPTH(1); - iterNum = INT2PTR(tmpPtr->internalRep.twoPtrValue.ptr1); - iterMax = INT2PTR(tmpPtr->internalRep.twoPtrValue.ptr2); + iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1); + iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2); /* * If some list still has a remaining list element iterate one more -- cgit v0.12 From 0c65e944bba3a82f5458182d31eedce8d648730c Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 6 Dec 2013 14:29:49 +0000 Subject: change NULL to INT2PTR(0), for clarity --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b6d8841..a3083bc 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6237,7 +6237,7 @@ TEBCresume( */ TclNewObj(tmpPtr); - tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; + tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0); tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax); PUSH_OBJECT(tmpPtr); /* iterCounts object */ -- cgit v0.12 From 1adbdd114bfb98364768cbf8e6b2d5c27700f392 Mon Sep 17 00:00:00 2001 From: mig Date: Tue, 10 Dec 2013 11:38:17 +0000 Subject: new INST_LMAP_COLLECT, speeds up lmap and eliminates the need for a temp var --- generic/tclCompCmds.c | 42 ++++++++++++++---------------------------- generic/tclCompile.c | 1 + generic/tclCompile.h | 3 ++- generic/tclExecute.c | 19 +++++++++++++++++++ 4 files changed, 36 insertions(+), 29 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index bdab2ff..cd43cfc 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2458,8 +2458,6 @@ CompileEachloopCmd( ForeachInfo *infoPtr; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ - int collectVar = -1; /* Index of temp var holding the result var - * index. */ Tcl_Token *tokenPtr, *bodyTokenPtr; int jumpBackOffset, infoIndex, range; @@ -2575,13 +2573,6 @@ CompileEachloopCmd( * We will compile the foreach command. */ - if (collect == TCL_EACH_COLLECT) { - collectVar = AnonymousLocal(envPtr); - if (collectVar < 0) { - return TCL_ERROR; - } - } - code = TCL_OK; /* @@ -2612,6 +2603,14 @@ CompileEachloopCmd( infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr); /* + * Create the collecting object, unshared. + */ + + if (collect == TCL_EACH_COLLECT) { + TclEmitInstInt4(INST_LIST, 0, envPtr); + } + + /* * Evaluate each value list and leave it on stack. */ @@ -2623,16 +2622,6 @@ CompileEachloopCmd( } } - /* - * Create temporary variable to capture return values from loop body. - */ - - if (collect == TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); /* @@ -2646,9 +2635,10 @@ CompileEachloopCmd( ExceptionRangeEnds(envPtr, range); if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); + TclEmitOpcode(INST_LMAP_COLLECT, envPtr); + } else { + TclEmitOpcode( INST_POP, envPtr); } - TclEmitOpcode( INST_POP, envPtr); /* * Bottom of loop code: assign each loop variable and check whether @@ -2672,15 +2662,11 @@ CompileEachloopCmd( infoPtr->loopCtTemp = -jumpBackOffset; /* - * The command's result is an empty string if not collecting, or the - * list of results from evaluating the loop body. + * The command's result is an empty string if not collecting. If + * collecting, it is automatically left on stack after FOREACH_END. */ - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } else { + if (collect != TCL_EACH_COLLECT) { PushStringLiteral(envPtr, ""); } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7cd9796..c7b7875 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -554,6 +554,7 @@ InstructionDesc const tclInstructionTable[] = { {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, /* "Step" or begin next iteration of foreach loop. */ {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, + {"lmap_collect", 1, 0, 0, {OPERAND_NONE}}, {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 8b1724b..7f62849 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -773,9 +773,10 @@ typedef struct ByteCode { #define INST_FOREACH_START 166 #define INST_FOREACH_STEP 167 #define INST_FOREACH_END 168 +#define INST_LMAP_COLLECT 169 /* The last opcode */ -#define LAST_INST_OPCODE 168 +#define LAST_INST_OPCODE 169 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a3083bc..9261f19 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6345,6 +6345,25 @@ TEBCresume( infoPtr = tmpPtr->internalRep.otherValuePtr; numLists = infoPtr->numLists; NEXT_INST_V(1, numLists+2, 0); + + case INST_LMAP_COLLECT: + /* + * This instruction is only issued by lmap. The stack is: + * - result + * - infoPtr + * - loop counters + * - valLists + * - collecting obj (unshared) + * The instruction lappends the result to the collecting obj. + */ + + tmpPtr = OBJ_AT_DEPTH(1); + infoPtr = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + + objPtr = OBJ_AT_DEPTH(3 + numLists); + Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); + NEXT_INST_F(1, 1, 0); } case INST_BEGIN_CATCH4: -- cgit v0.12 From 6446b79fe2dabdad88e22676d4be0c3e7134d044 Mon Sep 17 00:00:00 2001 From: mig Date: Tue, 10 Dec 2013 12:05:06 +0000 Subject: fix stack computations for lmap --- generic/tclCompile.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c7b7875..6c2e2b6 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -554,7 +554,7 @@ InstructionDesc const tclInstructionTable[] = { {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, /* "Step" or begin next iteration of foreach loop. */ {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, - {"lmap_collect", 1, 0, 0, {OPERAND_NONE}}, + {"lmap_collect", 1, -1, 0, {OPERAND_NONE}}, {NULL, 0, 0, 0, {OPERAND_NONE}} }; -- cgit v0.12 From 0cf62ad8a4ab59d5c3c41a2824308b3a9a1ee952 Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 13:49:20 +0000 Subject: simplifying: drop early the evaled script --- generic/tclCompCmds.c | 37 ++++++++----------------------------- 1 file changed, 8 insertions(+), 29 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index cd43cfc..0a0aa8e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,11 +610,10 @@ TclCompileCatchCmd( ExceptionRangeStarts(envPtr, range); TclEmitOpcode( INST_DUP, envPtr); TclEmitInvoke(envPtr, INST_EVAL_STK); + /* drop the script */ + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_POP, envPtr); } - /* Stack at this point: - * nonsimple: script result - * simple: result - */ if (resultIndex == -1) { /* @@ -632,14 +631,7 @@ TclCompileCatchCmd( TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); ExceptionRangeEnds(envPtr, range); TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * Stack at this point: - * nonsimple: script returnCode - * simple: returnCode - */ - - goto dropScriptAtEnd; + return TCL_OK; } /* @@ -649,7 +641,6 @@ TclCompileCatchCmd( PushStringLiteral(envPtr, "0"); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - /* Stack at this point: ?script? result TCL_OK */ /* * Emit the "error case" epilogue. Push the interpreter result and the @@ -658,7 +649,7 @@ TclCompileCatchCmd( TclAdjustStackDepth(-2, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); - /* Stack at this point: ?script? */ + /* Stack at this point is empty */ TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); @@ -666,7 +657,7 @@ TclCompileCatchCmd( * Update the target of the jump after the "no errors" code. */ - /* Stack at this point: ?script? result returnCode */ + /* Stack at this point: result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); @@ -689,7 +680,7 @@ TclCompileCatchCmd( /* * At this point, the top of the stack is inconveniently ordered: - * ?script? result returnCode ?returnOptions? + * result returnCode ?returnOptions? * Reverse the stack to bring the result to the top. */ @@ -707,7 +698,7 @@ TclCompileCatchCmd( TclEmitOpcode( INST_POP, envPtr); /* - * Stack is now ?script? ?returnOptions? returnCode. + * Stack is now ?returnOptions? returnCode. * If the options dict has been requested, it is buried on the stack under * the return code. Reverse the stack to bring it to the top, store it and * remove it from the stack. @@ -719,18 +710,6 @@ TclCompileCatchCmd( TclEmitOpcode( INST_POP, envPtr); } - dropScriptAtEnd: - - /* - * Stack is now ?script? result. Get rid of the subst'ed script if it's - * hanging arond. - */ - - if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - return TCL_OK; } -- cgit v0.12 From 6f08bd3872bc7784a56a139edfbfc8da5dcd2ca9 Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 14:51:15 +0000 Subject: store options early: simplify compiler, reduce stack manipulations --- generic/tclCompCmds.c | 32 ++++++-------------------------- 1 file changed, 6 insertions(+), 26 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0a0aa8e..65c50eb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -614,6 +614,7 @@ TclCompileCatchCmd( TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_POP, envPtr); } + ExceptionRangeEnds(envPtr, range); if (resultIndex == -1) { /* @@ -669,47 +670,26 @@ TclCompileCatchCmd( if (optsIndex != -1) { TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* * End the catch */ - ExceptionRangeEnds(envPtr, range); TclEmitOpcode( INST_END_CATCH, envPtr); /* * At this point, the top of the stack is inconveniently ordered: - * result returnCode ?returnOptions? - * Reverse the stack to bring the result to the top. - */ - - if (optsIndex != -1) { - TclEmitInstInt4( INST_REVERSE, 3, envPtr); - } else { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - } - - /* - * Store the result and remove it from the stack. + * result returnCode + * Reverse the stack to store the result. */ + TclEmitInstInt4( INST_REVERSE, 2, envPtr); Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); - /* - * Stack is now ?returnOptions? returnCode. - * If the options dict has been requested, it is buried on the stack under - * the return code. Reverse the stack to bring it to the top, store it and - * remove it from the stack. - */ - - if (optsIndex != -1) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - return TCL_OK; } -- cgit v0.12 From 411f830f50ba7611bc80e0cd72c18647637a40c7 Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 15:16:20 +0000 Subject: simplify: remove the special case --- generic/tclCompCmds.c | 25 ++++--------------------- 1 file changed, 4 insertions(+), 21 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 65c50eb..dbc876a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -616,25 +616,6 @@ TclCompileCatchCmd( } ExceptionRangeEnds(envPtr, range); - if (resultIndex == -1) { - /* - * Special case when neither result nor options are being saved. In - * that case, we can skip quite a bit of the command epilogue; all we - * have to do is drop the result and push the return code (and, of - * course, finish the catch context). - */ - - TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitInstInt1( INST_JUMP1, 3, envPtr); - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - ExceptionRangeEnds(envPtr, range); - TclEmitOpcode( INST_END_CATCH, envPtr); - return TCL_OK; - } - /* * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, * and jump around the "error case" code. @@ -687,8 +668,10 @@ TclCompileCatchCmd( */ TclEmitInstInt4( INST_REVERSE, 2, envPtr); - Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + if (resultIndex != -1) { + Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); return TCL_OK; } -- cgit v0.12 From 51c5c21deee994f94d1885cda3634eb24af6291f Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 15:55:28 +0000 Subject: new test, and fix for bug --- generic/tclCompCmds.c | 15 +++++++++------ tests/compile.test | 30 ++++++++++++++++++++++++++++++ 2 files changed, 39 insertions(+), 6 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index dbc876a..7997efa 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -645,14 +645,8 @@ TclCompileCatchCmd( (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } - /* - * Push the return options if the caller wants them. - */ - if (optsIndex != -1) { TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); } /* @@ -662,6 +656,15 @@ TclCompileCatchCmd( TclEmitOpcode( INST_END_CATCH, envPtr); /* + * Push the return options if the caller wants them. + */ + + if (optsIndex != -1) { + Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + + /* * At this point, the top of the stack is inconveniently ordered: * result returnCode * Reverse the stack to store the result. diff --git a/tests/compile.test b/tests/compile.test index 36e24de..2852bf2 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -167,6 +167,36 @@ test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*} -cleanup {namespace delete catchtest} } +test compile-3.7 {TclCompileCatchCmd: error in storing options [Bug 3098302]} {*}{ + -setup { + namespace eval catchtest { + variable options1 {} + } + trace add variable catchtest::options1 write catchtest::failtrace + proc catchtest::failtrace {n1 n2 op} { + return -code error "trace on $n1 fails by request" + } + } + -body { + proc catchtest::x {} { + variable options1 + set count 0 + for {set i 0} {$i < 10} {incr i} { + set status2 [catch { + set status1 [catch { + return -code error -level 0 "original failure" + } result1 options1] + } result2 options2] + incr count + } + list $count $result2 + } + catchtest::x + } + -result {10 {can't set "options1": trace on options1 fails by request}} + -cleanup {namespace delete catchtest} +} + test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 set j 0 -- cgit v0.12 From e8186595e3a8f553931aa8c12df92c721547b886 Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 16:27:59 +0000 Subject: comments --- generic/tclCompCmds.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7997efa..e071bbd 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -645,6 +645,11 @@ TclCompileCatchCmd( (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } + /* + * Push the return options if the caller wants them. This needs to happen + * before INST_END_CATCH + */ + if (optsIndex != -1) { TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); } @@ -656,7 +661,8 @@ TclCompileCatchCmd( TclEmitOpcode( INST_END_CATCH, envPtr); /* - * Push the return options if the caller wants them. + * Save the result and return options if the caller wants them. This needs + * to happen after INST_END_CATCH (compile-3.6/7). */ if (optsIndex != -1) { -- cgit v0.12 From ac531cc46362695ecb32cdb5e6c9a797133235a8 Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 16:33:21 +0000 Subject: comments --- generic/tclCompCmds.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index e071bbd..43504bf 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -635,16 +635,13 @@ TclCompileCatchCmd( TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - /* - * Update the target of the jump after the "no errors" code. - */ - - /* Stack at this point: result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } + /* Stack at this point: result returnCode */ + /* * Push the return options if the caller wants them. This needs to happen * before INST_END_CATCH -- cgit v0.12 From 3ad596b1a514f2048e1de737443824218c2ac3d9 Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 16:43:26 +0000 Subject: comments --- generic/tclCompCmds.c | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 43504bf..72b338c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -582,11 +582,7 @@ TclCompileCatchCmd( /* * We will compile the catch command. Declare the exception range that it * uses. - */ - - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - - /* + * * If the body is a simple word, compile a BEGIN_CATCH instruction, * followed by the instructions to eval the body. * Otherwise, compile instructions to substitute the body text before @@ -599,6 +595,7 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -635,13 +632,13 @@ TclCompileCatchCmd( TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); + /* Stack at this point on both branches: result returnCode */ + if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } - /* Stack at this point: result returnCode */ - /* * Push the return options if the caller wants them. This needs to happen * before INST_END_CATCH -- cgit v0.12 From f1a1245d74bbbc26c59675ae71e92c8ee3eeb572 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 12 Dec 2013 09:57:38 +0000 Subject: simple compilation of [string replace] --- generic/tclCmdMZ.c | 2 +- generic/tclCompCmdsSZ.c | 116 ++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 ++ 3 files changed, 120 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index da8ffe3..cefe850 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3339,7 +3339,7 @@ TclInitStringCmd( {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0}, {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, + {"replace", StringRplcCmd, TclCompileStringReplaceCmd, NULL, NULL, 0}, {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"tolower", StringLowerCmd, TclCompileStringToLowerCmd, NULL, NULL, 0}, {"toupper", StringUpperCmd, TclCompileStringToUpperCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index ca4b316..e7b3ddc 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -658,6 +658,122 @@ TclCompileStringRangeCmd( return TCL_OK; } +int +TclCompileStringReplaceCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL; + DefineLineInformation; /* TIP #280 */ + int idx1, idx2; + + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { + return TCL_ERROR; + } + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(valueTokenPtr); + tokenPtr = TokenAfter(tokenPtr); + replacementTokenPtr = TokenAfter(tokenPtr); + } + + /* + * Parse the indices. Will only compile special cases if both are + * constants and not an _integer_ less than zero (since we reserve + * negative indices here for end-relative indexing) or an end-based index + * greater than 'end' itself. + */ + + tokenPtr = TokenAfter(valueTokenPtr); + if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { + goto genericReplace; + } + + tokenPtr = TokenAfter(tokenPtr); + if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + goto genericReplace; + } + + /* + * We handle these replacements specially: first character (where + * idx1=idx2=0) and suffixes (where idx1=idx2=INDEX_END). Anything else + * and the semantics get rather screwy. + */ + + if (idx1 == 0 && idx2 == 0) { + int notEq, end; + + /* + * Just working with the first character. + */ + + CompileWord(envPtr, valueTokenPtr, interp, 1); + if (replacementTokenPtr == NULL) { + /* Drop first */ + OP44( STR_RANGE_IMM, 1, INDEX_END); + return TCL_OK; + } + /* Replace first */ + CompileWord(envPtr, replacementTokenPtr, interp, 4); + OP4( OVER, 1); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP_FALSE, notEq); + OP( POP); + JUMP1( JUMP, end); + FIXJUMP1(notEq); + TclAdjustStackDepth(1, envPtr); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, 1, INDEX_END); + OP1( STR_CONCAT1, 2); + FIXJUMP1(end); + return TCL_OK; + + } else if (idx1 == INDEX_END && idx2 == INDEX_END) { + int notEq, end; + + /* + * Just working with the last character. + */ + + CompileWord(envPtr, valueTokenPtr, interp, 1); + if (replacementTokenPtr == NULL) { + /* Drop last */ + OP44( STR_RANGE_IMM, 0, INDEX_END-1); + return TCL_OK; + } + /* Replace last */ + CompileWord(envPtr, replacementTokenPtr, interp, 4); + OP4( OVER, 1); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP_FALSE, notEq); + OP( POP); + JUMP1( JUMP, end); + FIXJUMP1(notEq); + TclAdjustStackDepth(1, envPtr); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, 0, INDEX_END-1); + OP4( REVERSE, 2); + OP1( STR_CONCAT1, 2); + FIXJUMP1(end); + return TCL_OK; + + } else { + /* + * Too complicated to optimize, but we know the number of arguments is + * correct so we can issue a call of the "standard" implementation. + */ + + genericReplace: + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } +} + /* * Synch with tclCmdMZ.c */ diff --git a/generic/tclInt.h b/generic/tclInt.h index aac94ca..ad17415 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3621,6 +3621,9 @@ MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringReplaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringToLowerCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 0011796c302a18d617907e137b3f327fc5a4a814 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Dec 2013 18:39:12 +0000 Subject: Simplify the coding of the unchain operation. --- generic/tclCmdIL.c | 40 +++++++++------------------------------- 1 file changed, 9 insertions(+), 31 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 57434c1..fc2c367 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -105,7 +105,6 @@ typedef struct SortInfo { */ static CmdFrame * CmdFrameChain(CoroutineData *corPtr); -static void CmdFrameUnchain(CoroutineData *corPtr); static int DictionaryCompare(const char *left, const char *right); static int IfConditionCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -1150,7 +1149,7 @@ InfoFrameCmd( { Interp *iPtr = (Interp *) interp; int level, topLevel, code = TCL_OK; - CmdFrame *runPtr, *framePtr; + CmdFrame *runPtr, *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; if (objc > 2) { @@ -1235,36 +1234,13 @@ InfoFrameCmd( Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); done: - if (corPtr) { + while (corPtr) { + CmdFrame *endPtr = corPtr->caller.cmdFramePtr; - if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) { - iPtr->cmdFramePtr = NULL; + if (*cmdFramePtrPtr == endPtr) { + *cmdFramePtrPtr = NULL; } else { - runPtr = iPtr->cmdFramePtr; - while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) { - runPtr->level -= corPtr->caller.cmdFramePtr->level; - runPtr = runPtr->nextPtr; - } - runPtr->level = 1; - runPtr->nextPtr = NULL; - } - CmdFrameUnchain(corPtr); - - } - return code; -} - -static void -CmdFrameUnchain( - CoroutineData *corPtr) -{ - if (corPtr->callerEEPtr->corPtr) { - CmdFrame *endPtr = corPtr->callerEEPtr->corPtr->caller.cmdFramePtr; - - if (corPtr->caller.cmdFramePtr == endPtr) { - corPtr->caller.cmdFramePtr = NULL; - } else { - CmdFrame *runPtr = corPtr->caller.cmdFramePtr; + CmdFrame *runPtr = *cmdFramePtrPtr; while (runPtr->nextPtr != endPtr) { runPtr->level -= endPtr->level; @@ -1273,8 +1249,10 @@ CmdFrameUnchain( runPtr->level = 1; runPtr->nextPtr = NULL; } - CmdFrameUnchain(corPtr->callerEEPtr->corPtr); + cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; + corPtr = corPtr->callerEEPtr->corPtr; } + return code; } static CmdFrame * -- cgit v0.12 From 27e8904ab461abff61be9b7612d7e4ef61e08679 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 15 Dec 2013 17:49:53 +0000 Subject: Improve descriptions of character escapes and ranges in Tcl.n. Improve output format handlers to cope with added escape for en-dashes. --- doc/Tcl.n | 39 ++++++++++++++++++++++----------------- tools/man2help2.tcl | 2 +- tools/tcltk-man2html-utils.tcl | 1 + 3 files changed, 24 insertions(+), 18 deletions(-) diff --git a/doc/Tcl.n b/doc/Tcl.n index 8b17f93..c7fa9f6 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -108,8 +108,8 @@ Variable substitution may take any of the following forms: \fIName\fR is the name of a scalar variable; the name is a sequence of one or more characters that are a letter, digit, underscore, or namespace separators (two or more colons). -Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\-\fB9\fR, -\fBA\fR\-\fBZ\fR and \fBa\fR\-\fBz\fR). +Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\(en\fB9\fR, +\fBA\fR\(en\fBZ\fR and \fBa\fR\(en\fBz\fR). .TP 15 \fB$\fIname\fB(\fIindex\fB)\fR . @@ -117,8 +117,8 @@ Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\-\fB9\fR, the name of an element within that array. \fIName\fR must contain only letters, digits, underscores, and namespace separators, and may be an empty string. -Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\-\fB9\fR, -\fBA\fR\-\fBZ\fR and \fBa\fR\-\fBz\fR). +Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\(en\fB9\fR, +\fBA\fR\(en\fBZ\fR and \fBa\fR\(en\fBz\fR). Command substitutions, variable substitutions, and backslash substitutions are performed on the characters of \fIindex\fR. .TP 15 @@ -158,25 +158,25 @@ handled specially, along with the value that replaces each sequence. .RS .TP 7 \e\fBa\fR -Audible alert (bell) (0x7). +Audible alert (bell) (Unicode U+000007). .TP 7 \e\fBb\fR -Backspace (0x8). +Backspace (Unicode U+000008). .TP 7 \e\fBf\fR -Form feed (0xc). +Form feed (Unicode U+00000C). .TP 7 \e\fBn\fR -Newline (0xa). +Newline (Unicode U+00000A). .TP 7 \e\fBr\fR -Carriage-return (0xd). +Carriage-return (Unicode U+00000D). .TP 7 \e\fBt\fR -Tab (0x9). +Tab (Unicode U+000009). .TP 7 \e\fBv\fR -Vertical tab (0xb). +Vertical tab (Unicode U+00000B). .TP 7 \e\fB\fIwhiteSpace\fR . @@ -194,8 +194,9 @@ Backslash \e\fIooo\fR . The digits \fIooo\fR (one, two, or three of them) give a eight-bit octal -value for the Unicode character that will be inserted, in the range \fI000\fR -- \fI377\fR. The parser will stop just before this range overflows, or when +value for the Unicode character that will be inserted, in the range +\fI000\fR\(en\fI377\fR (i.e., the range U+000000\(enU+0000FF). +The parser will stop just before this range overflows, or when the maximum of three digits is reached. The upper bits of the Unicode character will be 0. .TP 7 @@ -203,23 +204,27 @@ character will be 0. . The hexadecimal digits \fIhh\fR (one or two of them) give an eight-bit hexadecimal value for the Unicode character that will be inserted. The upper -bits of the Unicode character will be 0. +bits of the Unicode character will be 0 (i.e., the character will be in the +range U+000000\(enU+0000FF). .TP 7 \e\fBu\fIhhhh\fR . The hexadecimal digits \fIhhhh\fR (one, two, three, or four of them) give a sixteen-bit hexadecimal value for the Unicode character that will be -inserted. The upper bits of the Unicode character will be 0. +inserted. The upper bits of the Unicode character will be 0 (i.e., the +character will be in the range U+000000\(enU+00FFFF). .TP 7 \e\fBU\fIhhhhhhhh\fR . The hexadecimal digits \fIhhhhhhhh\fR (one up to eight of them) give a twenty-one-bit hexadecimal value for the Unicode character that will be -inserted, in the range U+0000..U+10FFFF. The parser will stop just +inserted, in the range U+000000\(enU+10FFFF. The parser will stop just before this range overflows, or when the maximum of eight digits is reached. The upper bits of the Unicode character will be 0. +.RS .PP -The range U+010000..U+10FFFD is reserved for the future. +The range U+010000\(enU+10FFFD is reserved for the future. +.RE .PP Backslash substitution is not performed on words enclosed in braces, except for backslash-newline as described above. diff --git a/tools/man2help2.tcl b/tools/man2help2.tcl index fe4e7ad..9c8f503 100644 --- a/tools/man2help2.tcl +++ b/tools/man2help2.tcl @@ -717,7 +717,7 @@ proc char {name} { textSetup puts -nonewline $file "\\'d7 " } - {\(em} { + {\(em} - {\(en} { textSetup puts -nonewline $file "-" } diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index bdd0079..8fd1245 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -142,6 +142,7 @@ proc process-text {text} { {\(+-} "±" \ {\(co} "©" \ {\(em} "—" \ + {\(en} "–" \ {\(fm} "′" \ {\(mu} "×" \ {\(mi} "−" \ -- cgit v0.12 From fc27205f3f2b5a493f16aecd71309144cf751035 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 16 Dec 2013 21:01:35 +0000 Subject: Refactoring work on the "chain" operation. --- generic/tclCmdIL.c | 101 +++++++++++++++++++++++++---------------------------- 1 file changed, 48 insertions(+), 53 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index fc2c367..28fb3ce 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -104,7 +104,7 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ -static CmdFrame * CmdFrameChain(CoroutineData *corPtr); +static void CmdFrameChain(CoroutineData *corPtr); static int DictionaryCompare(const char *left, const char *right); static int IfConditionCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -1140,6 +1140,47 @@ TclInfoExistsCmd( *---------------------------------------------------------------------- */ +static void +Chain( + CmdFrame **cmdFramePtrPtr, + CoroutineData *corPtr) +{ + CmdFrame *tailPtr = corPtr->caller.cmdFramePtr; + CmdFrame *runPtr = *cmdFramePtrPtr; + int offset; + + if (tailPtr == NULL) { + return; + } + + if (runPtr == NULL) { + *cmdFramePtrPtr = tailPtr; + return; + } + + offset = tailPtr->level; + + while (runPtr->nextPtr) { + runPtr->level += offset; + runPtr = runPtr->nextPtr; + } + runPtr->level += offset; + runPtr->nextPtr = tailPtr; +} + +static void +CmdFrameChain( + CoroutineData *corPtr) +{ + CmdFrame **cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; + + corPtr = corPtr->callerEEPtr->corPtr; + if (corPtr) { + CmdFrameChain(corPtr); + Chain(cmdFramePtrPtr, corPtr); + } +} + static int InfoFrameCmd( ClientData dummy, /* Not used. */ @@ -1149,7 +1190,7 @@ InfoFrameCmd( { Interp *iPtr = (Interp *) interp; int level, topLevel, code = TCL_OK; - CmdFrame *runPtr, *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; + CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; if (objc > 2) { @@ -1157,36 +1198,13 @@ InfoFrameCmd( return TCL_ERROR; } - topLevel = ((iPtr->cmdFramePtr == NULL) - ? 0 - : iPtr->cmdFramePtr->level); - if (corPtr) { - /* - * A coroutine: must fix the level computations AND the cmdFrame chain, - * which is interrupted at the base. - */ - - CmdFrame *lastPtr = NULL; - CmdFrame *tailPtr = CmdFrameChain(corPtr); - int offset = tailPtr ? tailPtr->level : 0; - - runPtr = iPtr->cmdFramePtr; - - /* TODO - deal with overflow */ - topLevel += offset; - while (runPtr) { - runPtr->level += offset; - lastPtr = runPtr; - runPtr = runPtr->nextPtr; - } - if (lastPtr) { - lastPtr->nextPtr = tailPtr; - } else { - iPtr->cmdFramePtr = tailPtr; - } + CmdFrameChain(corPtr); + Chain(cmdFramePtrPtr, corPtr); } + topLevel = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level : 0; + if (objc == 1) { /* * Just "info frame". @@ -1234,6 +1252,7 @@ InfoFrameCmd( Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); done: + cmdFramePtrPtr = &iPtr->cmdFramePtr; while (corPtr) { CmdFrame *endPtr = corPtr->caller.cmdFramePtr; @@ -1254,30 +1273,6 @@ InfoFrameCmd( } return code; } - -static CmdFrame * -CmdFrameChain( - CoroutineData *corPtr) -{ - if (corPtr->callerEEPtr->corPtr) { - CmdFrame *tailPtr = CmdFrameChain(corPtr->callerEEPtr->corPtr); - CmdFrame *lastPtr = NULL; - CmdFrame *runPtr = corPtr->caller.cmdFramePtr; - int offset = tailPtr ? tailPtr->level : 0; - - while (runPtr) { - runPtr->level += offset; - lastPtr = runPtr; - runPtr = runPtr->nextPtr; - } - if (lastPtr) { - lastPtr->nextPtr = tailPtr; - } else { - corPtr->caller.cmdFramePtr = tailPtr; - } - } - return corPtr->caller.cmdFramePtr; -} /* *---------------------------------------------------------------------- -- cgit v0.12 From 4994878d50513c14551effdbacd0d8b89f8bec02 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 17 Dec 2013 21:19:36 +0000 Subject: Factor out the level offsetting into a final pass. Let the first pass of the "chain" operation just stitch things together and count levels. --- generic/tclCmdIL.c | 43 +++++++++++++++++++++++++++---------------- 1 file changed, 27 insertions(+), 16 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 28fb3ce..e26c211 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -104,7 +104,7 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ -static void CmdFrameChain(CoroutineData *corPtr); +static int CmdFrameChain(CoroutineData *corPtr); static int DictionaryCompare(const char *left, const char *right); static int IfConditionCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -1140,45 +1140,47 @@ TclInfoExistsCmd( *---------------------------------------------------------------------- */ -static void +static int Chain( CmdFrame **cmdFramePtrPtr, CoroutineData *corPtr) { CmdFrame *tailPtr = corPtr->caller.cmdFramePtr; CmdFrame *runPtr = *cmdFramePtrPtr; - int offset; if (tailPtr == NULL) { - return; + /* Think this can't happen. */ + return 0; } if (runPtr == NULL) { + int toReturn = tailPtr->level; + *cmdFramePtrPtr = tailPtr; - return; + tailPtr->level = 0; + return toReturn; } - offset = tailPtr->level; - while (runPtr->nextPtr) { - runPtr->level += offset; runPtr = runPtr->nextPtr; } - runPtr->level += offset; runPtr->nextPtr = tailPtr; + return tailPtr->level; } -static void +static int CmdFrameChain( CoroutineData *corPtr) { CmdFrame **cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; + int sum = 0; corPtr = corPtr->callerEEPtr->corPtr; if (corPtr) { - CmdFrameChain(corPtr); - Chain(cmdFramePtrPtr, corPtr); + sum += CmdFrameChain(corPtr); + sum += Chain(cmdFramePtrPtr, corPtr); } + return sum; } static int @@ -1189,9 +1191,10 @@ InfoFrameCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - int level, topLevel, code = TCL_OK; + int level, code = TCL_OK; CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + int topLevel = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level : 0; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?number?"); @@ -1199,11 +1202,19 @@ InfoFrameCmd( } if (corPtr) { - CmdFrameChain(corPtr); - Chain(cmdFramePtrPtr, corPtr); + topLevel += CmdFrameChain(corPtr); + topLevel += Chain(cmdFramePtrPtr, corPtr); } - topLevel = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level : 0; + framePtr = iPtr->cmdFramePtr; + while (framePtr) { + framePtr->level = topLevel--; + framePtr = framePtr->nextPtr; + } + if (topLevel) { + Tcl_Panic("Broken frame level calculation"); + } + topLevel = iPtr->cmdFramePtr->level; if (objc == 1) { /* -- cgit v0.12 From 1412caa12be1ae5a29ff7b5ff0205a877debb09b Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 18 Dec 2013 15:34:39 +0000 Subject: Making the optimizer pluggable by extensions; please review for committing to trunk --- generic/tclBasic.c | 3 +++ generic/tclCompile.c | 4 +++- generic/tclCompile.h | 2 +- generic/tclInt.h | 9 ++++++++- generic/tclOptimize.c | 2 +- 5 files changed, 16 insertions(+), 4 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a41351e..8ec94ca 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -526,6 +526,9 @@ Tcl_CreateInterp(void) iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; + TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable)); + iPtr->extra.optimizer = TclOptimizeBytecode; + iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; /* Initialise as soon as :: is available */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6c2e2b6..525571d 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -765,7 +765,9 @@ TclSetByteCodeFromAny( * instruction generator boundaries. */ - TclOptimizeBytecode(&compEnv); + if (iPtr->extra.optimizer) { + (iPtr->extra.optimizer)(&compEnv); + } /* * Invoke the compilation hook procedure if one exists. diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 7f62849..55dd37a 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1064,7 +1064,7 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif -MODULE_SCOPE void TclOptimizeBytecode(CompileEnv *envPtr); +MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr); diff --git a/generic/tclInt.h b/generic/tclInt.h index 5c8dbfd..8ccfadb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1809,7 +1809,14 @@ typedef struct Interp { ClientData interpInfo; /* Information used by tclInterp.c to keep * track of master/slave interps on a * per-interp basis. */ - Tcl_HashTable unused2; /* No longer used (was mathFuncTable) */ + union { + void (*optimizer)(void *envPtr); + Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The + * unused space in interp was repurposed for + * pluggable bytecode optimizers. The core + * contains one optimizer, which can be + * selectively overriden by extensions. */ + } extra; /* * Information related to procedures and variables. See tclProc.c and diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 3b16e6e..74de7a3 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -427,7 +427,7 @@ AdvanceJumps( void TclOptimizeBytecode( - CompileEnv *envPtr) + void *envPtr) { ConvertZeroEffectToNOP(envPtr); AdvanceJumps(envPtr); -- cgit v0.12 From b12d345ba76321d49ce01dc70501e279ea796526 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 18 Dec 2013 18:09:09 +0000 Subject: Big simplification of the bug fix. --- generic/tclCmdIL.c | 100 ++++++++++++++++++----------------------------------- 1 file changed, 34 insertions(+), 66 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index e26c211..41c1eb6 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -104,7 +104,6 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ -static int CmdFrameChain(CoroutineData *corPtr); static int DictionaryCompare(const char *left, const char *right); static int IfConditionCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -1140,49 +1139,6 @@ TclInfoExistsCmd( *---------------------------------------------------------------------- */ -static int -Chain( - CmdFrame **cmdFramePtrPtr, - CoroutineData *corPtr) -{ - CmdFrame *tailPtr = corPtr->caller.cmdFramePtr; - CmdFrame *runPtr = *cmdFramePtrPtr; - - if (tailPtr == NULL) { - /* Think this can't happen. */ - return 0; - } - - if (runPtr == NULL) { - int toReturn = tailPtr->level; - - *cmdFramePtrPtr = tailPtr; - tailPtr->level = 0; - return toReturn; - } - - while (runPtr->nextPtr) { - runPtr = runPtr->nextPtr; - } - runPtr->nextPtr = tailPtr; - return tailPtr->level; -} - -static int -CmdFrameChain( - CoroutineData *corPtr) -{ - CmdFrame **cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; - int sum = 0; - - corPtr = corPtr->callerEEPtr->corPtr; - if (corPtr) { - sum += CmdFrameChain(corPtr); - sum += Chain(cmdFramePtrPtr, corPtr); - } - return sum; -} - static int InfoFrameCmd( ClientData dummy, /* Not used. */ @@ -1194,27 +1150,36 @@ InfoFrameCmd( int level, code = TCL_OK; CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - int topLevel = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level : 0; + int topLevel = 0; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?number?"); return TCL_ERROR; } - if (corPtr) { - topLevel += CmdFrameChain(corPtr); - topLevel += Chain(cmdFramePtrPtr, corPtr); + while (corPtr) { + while (*cmdFramePtrPtr) { + topLevel++; + cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr); + } + if (corPtr->caller.cmdFramePtr) { + *cmdFramePtrPtr = corPtr->caller.cmdFramePtr; + } + corPtr = corPtr->callerEEPtr->corPtr; } + topLevel += (*cmdFramePtrPtr)->level; - framePtr = iPtr->cmdFramePtr; - while (framePtr) { - framePtr->level = topLevel--; - framePtr = framePtr->nextPtr; - } - if (topLevel) { - Tcl_Panic("Broken frame level calculation"); + if (topLevel != iPtr->cmdFramePtr->level) { + framePtr = iPtr->cmdFramePtr; + while (framePtr) { + framePtr->level = topLevel--; + framePtr = framePtr->nextPtr; + } + if (topLevel) { + Tcl_Panic("Broken frame level calculation"); + } + topLevel = iPtr->cmdFramePtr->level; } - topLevel = iPtr->cmdFramePtr->level; if (objc == 1) { /* @@ -1264,22 +1229,25 @@ InfoFrameCmd( done: cmdFramePtrPtr = &iPtr->cmdFramePtr; + corPtr = iPtr->execEnvPtr->corPtr; while (corPtr) { CmdFrame *endPtr = corPtr->caller.cmdFramePtr; - if (*cmdFramePtrPtr == endPtr) { - *cmdFramePtrPtr = NULL; - } else { - CmdFrame *runPtr = *cmdFramePtrPtr; + if (endPtr) { + if (*cmdFramePtrPtr == endPtr) { + *cmdFramePtrPtr = NULL; + } else { + CmdFrame *runPtr = *cmdFramePtrPtr; - while (runPtr->nextPtr != endPtr) { - runPtr->level -= endPtr->level; - runPtr = runPtr->nextPtr; + while (runPtr->nextPtr != endPtr) { + runPtr->level -= endPtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; } - runPtr->level = 1; - runPtr->nextPtr = NULL; + cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; } - cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; corPtr = corPtr->callerEEPtr->corPtr; } return code; -- cgit v0.12 From f324306fb22db8c55d70ad39db00ee389545c2b5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 Dec 2013 14:35:50 +0000 Subject: Add TclRegisterLiteral() to internal stub table (from "mig-optimize" branch, looks like a good idea anyway) --- generic/tclCompile.h | 2 -- generic/tclInt.decls | 6 ++++++ generic/tclIntDecls.h | 6 ++++++ generic/tclLiteral.c | 3 ++- generic/tclStubInit.c | 1 + 5 files changed, 15 insertions(+), 3 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 55dd37a..b421aaf 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1079,8 +1079,6 @@ MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *isScalarPtr); -MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, - char *bytes, int length, int flags); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index f0e907f..9f7b106 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1006,6 +1006,12 @@ declare 249 { declare 250 { void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force) } + +# Allow extensions for optimization +declare 251 { + int TclRegisterLiteral(void *envPtr, + char *bytes, int length, int flags) +} ############################################################################## diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 47c6afd..f95f999 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -614,6 +614,9 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, /* 250 */ EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); +/* 251 */ +EXTERN int TclRegisterLiteral(void *envPtr, char *bytes, + int length, int flags); typedef struct TclIntStubs { int magic; @@ -870,6 +873,7 @@ typedef struct TclIntStubs { int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ + int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; @@ -1299,6 +1303,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclDoubleDigits) /* 249 */ #define TclSetSlaveCancelFlags \ (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */ +#define TclRegisterLiteral \ + (tclIntStubsPtr->tclRegisterLiteral) /* 251 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 11da6f8..2b0cc7e 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -358,7 +358,7 @@ TclFetchLiteral( int TclRegisterLiteral( - CompileEnv *envPtr, /* Points to the CompileEnv in whose object + void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ register char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object @@ -372,6 +372,7 @@ TclRegisterLiteral( * the literal should not be shared accross * namespaces. */ { + CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 3f1c27b..e1918ef 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -551,6 +551,7 @@ static const TclIntStubs tclIntStubs = { TclCopyChannel, /* 248 */ TclDoubleDigits, /* 249 */ TclSetSlaveCancelFlags, /* 250 */ + TclRegisterLiteral, /* 251 */ }; static const TclIntPlatStubs tclIntPlatStubs = { -- cgit v0.12 From 6bde9d5683a83fe17b6dfc337b4865055ccb2067 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 20 Dec 2013 21:59:28 +0000 Subject: remove INST_TRY_CVT_TO_NUMERIC when it is known not be necessary (cherrypick from mig-optimize) --- generic/tclCompCmds.c | 1 + generic/tclCompCmdsGR.c | 2 ++ generic/tclCompCmdsSZ.c | 1 + generic/tclCompile.h | 12 ++++++++++++ 4 files changed, 16 insertions(+) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 72b338c..b7fc9b5 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2276,6 +2276,7 @@ TclCompileForCmd( SetLineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + TclClearNumConversion(envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index d00327d..b7c89df 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -229,6 +229,7 @@ TclCompileIfCmd( SetLineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + TclClearNumConversion(envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } @@ -478,6 +479,7 @@ TclCompileIncrCmd( } else { SetLineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); + TclClearNumConversion(envPtr); } } else { /* No incr amount given so use 1. */ haveImmValue = 1; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 754238f..3e4a55a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -3071,6 +3071,7 @@ TclCompileWhileCmd( } SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + TclClearNumConversion(envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b421aaf..287ab1d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1309,6 +1309,18 @@ 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: -- cgit v0.12 From 0065bfd6bc2af3245e8c7f988c17cb0995b9da23 Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 22 Dec 2013 12:52:39 +0000 Subject: fix stack counting bug in new catch compiler, commit 62a51cdb45. --- generic/tclCompCmds.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index b7fc9b5..94d3a69 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -533,7 +533,7 @@ TclCompileCatchCmd( { JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - int resultIndex, optsIndex, range; + int resultIndex, optsIndex, range, dropScript = 0; DefineLineInformation; /* TIP #280 */ /* @@ -601,6 +601,7 @@ TclCompileCatchCmd( ExceptionRangeStarts(envPtr, range); BODY(cmdTokenPtr, 1); } else { + dropScript = 1; SetLineInformation(1); CompileTokens(envPtr, cmdTokenPtr, interp); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); @@ -608,6 +609,7 @@ TclCompileCatchCmd( TclEmitOpcode( INST_DUP, envPtr); TclEmitInvoke(envPtr, INST_EVAL_STK); /* drop the script */ + dropScript = 1; TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -626,8 +628,12 @@ TclCompileCatchCmd( * return code. */ - TclAdjustStackDepth(-2, envPtr); + TclAdjustStackDepth(-2 + dropScript, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); + if (dropScript) { + TclEmitOpcode( INST_POP, envPtr); + } + /* Stack at this point is empty */ TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); -- cgit v0.12 From 9b9e35d8149caef38c952b2929aedd1c8e6df6a5 Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 22 Dec 2013 13:03:19 +0000 Subject: remove duplicate statement in previous commit --- generic/tclCompCmds.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 94d3a69..d6f01a8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -601,7 +601,6 @@ TclCompileCatchCmd( ExceptionRangeStarts(envPtr, range); BODY(cmdTokenPtr, 1); } else { - dropScript = 1; SetLineInformation(1); CompileTokens(envPtr, cmdTokenPtr, interp); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); -- cgit v0.12 From c339e592051bb83c9890a27b6709e3929489889b Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 22 Dec 2013 14:11:46 +0000 Subject: remove unnecessary messing around INST_CONTINUE and INST_BREAK: local continue/break are already converted to jumps, so that these are either caught or returned - in either case, the stacks are cleaned up properly by TEBC itself. --- generic/tclCompCmds.c | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index d6f01a8..c774a5e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -489,17 +489,14 @@ TclCompileBreakCmd( TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopBreakFixup(envPtr, auxPtr); - TclAdjustStackDepth(1, envPtr); } else { /* * Emit a real break. */ - PushStringLiteral(envPtr, ""); - TclEmitOpcode(INST_DUP, envPtr); - TclEmitInstInt4(INST_RETURN_IMM, TCL_BREAK, envPtr); - TclEmitInt4(0, envPtr); + TclEmitOpcode(INST_BREAK, envPtr); } + TclAdjustStackDepth(1, envPtr); return TCL_OK; } @@ -735,17 +732,14 @@ TclCompileContinueCmd( TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopContinueFixup(envPtr, auxPtr); - TclAdjustStackDepth(1, envPtr); } else { /* * Emit a real continue. */ - PushStringLiteral(envPtr, ""); - TclEmitOpcode(INST_DUP, envPtr); - TclEmitInstInt4(INST_RETURN_IMM, TCL_CONTINUE, envPtr); - TclEmitInt4(0, envPtr); + TclEmitOpcode(INST_CONTINUE, envPtr); } + TclAdjustStackDepth(1, envPtr); return TCL_OK; } -- cgit v0.12 From 724d7b20d49b89df2f76ef22181cca990e691478 Mon Sep 17 00:00:00 2001 From: mig Date: Mon, 23 Dec 2013 11:28:12 +0000 Subject: Added new tools for managing and verifying the stack depth during compilation. Used it in some spots in the compiler and in TclCompileCatchCommand. --- generic/tclCompCmds.c | 10 ++++++++-- generic/tclCompile.c | 34 +++++++++++++++++++++++++--------- generic/tclCompile.h | 15 +++++++++++++++ 3 files changed, 48 insertions(+), 11 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c774a5e..323aa87 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -532,7 +532,8 @@ TclCompileCatchCmd( Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; int resultIndex, optsIndex, range, dropScript = 0; DefineLineInformation; /* TIP #280 */ - + int depth = TclGetStackDepth(envPtr); + /* * If syntax does not match what we expect for [catch], do not compile. * Let runtime checks determine if syntax has changed. @@ -611,11 +612,13 @@ TclCompileCatchCmd( } ExceptionRangeEnds(envPtr, range); + /* * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, * and jump around the "error case" code. */ + TclCheckStackDepth(depth+1, envPtr); PushStringLiteral(envPtr, "0"); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); @@ -624,12 +627,14 @@ TclCompileCatchCmd( * return code. */ - TclAdjustStackDepth(-2 + dropScript, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); + TclSetStackDepth(depth + dropScript, envPtr); + if (dropScript) { TclEmitOpcode( INST_POP, envPtr); } + /* Stack at this point is empty */ TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); @@ -678,6 +683,7 @@ TclCompileCatchCmd( } TclEmitOpcode( INST_POP, envPtr); + TclCheckStackDepth(depth+1, envPtr); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 525571d..f3e9db3 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1722,7 +1722,7 @@ TclCompileInvocation( int numWords, CompileEnv *envPtr) { - int wordIdx = 0; + int wordIdx = 0, depth = TclGetStackDepth(envPtr); DefineLineInformation; if (cmdObj) { @@ -1755,6 +1755,7 @@ TclCompileInvocation( } else { TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); } + TclCheckStackDepth(depth+1, envPtr); } static void @@ -1767,7 +1768,8 @@ CompileExpanded( { int wordIdx = 0; DefineLineInformation; - + int depth = TclGetStackDepth(envPtr); + StartExpanding(envPtr); if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -1813,6 +1815,7 @@ CompileExpanded( */ TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); + TclCheckStackDepth(depth+1, envPtr); } static int @@ -1824,6 +1827,7 @@ CompileCmdCompileProc( { int unwind = 0, incrOffset = -1; DefineLineInformation; + int depth = TclGetStackDepth(envPtr); /* * Emit of the INST_START_CMD instruction is controlled by the value of @@ -1871,6 +1875,7 @@ CompileCmdCompileProc( TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); } } + TclCheckStackDepth(depth+1, envPtr); return TCL_OK; } @@ -1913,7 +1918,8 @@ CompileCommandTokens( int *clNext = envPtr->clNext; int cmdIdx = envPtr->numCommands; int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - + int depth = TclGetStackDepth(envPtr); + assert (parsePtr->numWords > 0); /* Pre-Compile */ @@ -2004,6 +2010,7 @@ CompileCommandTokens( eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; + TclCheckStackDepth(depth, envPtr); return cmdIdx; } @@ -2023,6 +2030,7 @@ TclCompileScript( * Initial value of -1 indicates this routine * has not yet generated any bytecode. */ const char *p = script; /* Where we are in our compile. */ + int depth = TclGetStackDepth(envPtr); if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); @@ -2134,6 +2142,7 @@ TclCompileScript( envPtr->codeNext--; envPtr->currStackDepth++; } + TclCheckStackDepth(depth+1, envPtr); } /* @@ -2244,6 +2253,7 @@ TclCompileTokens( #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; int *clPosition = NULL; + int depth = TclGetStackDepth(envPtr); /* * For the handling of continuation lines in literals we first check if @@ -2421,6 +2431,7 @@ TclCompileTokens( if (maxNumCL) { ckfree(clPosition); } + TclCheckStackDepth(depth+1, envPtr); } /* @@ -3936,7 +3947,8 @@ TclEmitInvoke( ExceptionAux *auxBreakPtr, *auxContinuePtr; int arg1, arg2, wordCount = 0, expandCount = 0; int loopRange = 0, breakRange = 0, continueRange = 0; - + int cleanup, depth = TclGetStackDepth(envPtr); + /* * Parse the arguments. */ @@ -3944,30 +3956,31 @@ TclEmitInvoke( va_start(argList, opcode); switch (opcode) { case INST_INVOKE_STK1: - wordCount = arg1 = va_arg(argList, int); + wordCount = arg1 = cleanup = va_arg(argList, int); arg2 = 0; break; case INST_INVOKE_STK4: - wordCount = arg1 = va_arg(argList, int); + wordCount = arg1 = cleanup = va_arg(argList, int); arg2 = 0; break; case INST_INVOKE_REPLACE: arg1 = va_arg(argList, int); arg2 = va_arg(argList, int); wordCount = arg1 + arg2 - 1; + cleanup = arg1 + 1; break; default: Tcl_Panic("unexpected opcode"); case INST_EVAL_STK: - wordCount = 1; + wordCount = cleanup = 1; arg1 = arg2 = 0; break; case INST_RETURN_STK: - wordCount = 2; + wordCount = cleanup = 2; arg1 = arg2 = 0; break; case INST_INVOKE_EXPANDED: - wordCount = arg1 = va_arg(argList, int); + wordCount = arg1 = cleanup = va_arg(argList, int); arg2 = 0; expandCount = 1; break; @@ -4070,6 +4083,7 @@ TclEmitInvoke( ExceptionRangeTarget(envPtr, loopRange, breakOffset); TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); TclAddLoopBreakFixup(envPtr, auxBreakPtr); + TclAdjustStackDepth(1, envPtr); envPtr->currStackDepth = savedStackDepth; envPtr->expandCount = savedExpandCount; @@ -4081,6 +4095,7 @@ TclEmitInvoke( ExceptionRangeTarget(envPtr, loopRange, continueOffset); TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); TclAddLoopContinueFixup(envPtr, auxContinuePtr); + TclAdjustStackDepth(1, envPtr); envPtr->currStackDepth = savedStackDepth; envPtr->expandCount = savedExpandCount; @@ -4089,6 +4104,7 @@ TclEmitInvoke( TclFinalizeLoopExceptionRange(envPtr, loopRange); TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); } + TclCheckStackDepth(depth+1-cleanup, envPtr); } /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 287ab1d..b3c8442 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1169,6 +1169,21 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); (envPtr)->currStackDepth += (delta); \ } while (0) +#define TclGetStackDepth(envPtr) \ + ((envPtr)->currStackDepth) + +#define TclSetStackDepth(depth, envPtr) \ + (envPtr)->currStackDepth = (depth) + +#define TclCheckStackDepth(depth, envPtr) \ + do { \ + int dd = (depth); \ + if (dd != (envPtr)->currStackDepth) { \ + Tcl_Panic("bad stack depth computations: is %i, should be %i", \ + (envPtr)->currStackDepth, dd); \ + } \ + } while (0) + /* * Macro used to update the stack requirements. It is called by the macros * TclEmitOpCode, TclEmitInst1 and TclEmitInst4. -- cgit v0.12 From 24707208d7110b121022a0c9078076e5813dc83e Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 24 Dec 2013 18:57:46 +0000 Subject: interim commit; not yet working --- generic/tclExecute.c | 120 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 120 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 73f388b..d178934 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5157,6 +5157,126 @@ TEBCresume( int length3; Tcl_Obj *value3Ptr; + case INST_STR_REPLACE: + valuePtr = OBJ_AT_DEPTH(3); + length = Tcl_GetCharLength(valuePtr) - 1; + value3Ptr = OBJ_AT_TOS; + TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), + O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(value3Ptr))); + if (TclGetIntForIndexM(interp, OBJ_AT_DEPTH(2), length, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + &toIdx) != TCL_OK) { + goto gotError; + } + if (fromIdx < 0) { + fromIdx = 0; + } + + if (fromIdx > toIdx || fromIdx > length) { + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(1, 3, 0); + } + + if (fromIdx == 0 && toIdx == length) { + objResultPtr = value3Ptr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 4, 1); + } + + length3 = Tcl_GetCharLength(value3Ptr); + + /* + * Remove substring. In-place. + */ + + if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) { + Tcl_SetObjLength(valuePtr, fromIdx); + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(1, 3, 0); + } + + // Splice in place. + + if (length3 == toIdx - fromIdx) { + unsigned char *bytes1, *bytes2; + + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + // splice "in place" + if (TclIsPureByteArray(objResultPtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(objResultPtr); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr); + } else { + } + NEXT_INST_F(1, 4, 1); + } else { + // splice "in place" + if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(valuePtr); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr); + } else { + } + NEXT_INST_F(1, 3, 0); + } + } + + /* + * Get the unicode representation; this is where we guarantee to lose + * bytearrays. + */ + + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + length--; + + /* + * Remove substring using copying. + */ + + if (length3 == 0) { + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else { + objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, + length - toIdx); + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 4, 1); + } + + /* + * Splice string pieces by full copying. + */ + + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + Tcl_AppendObjToObj(objResultPtr, value3Ptr); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else if (Tcl_IsShared(value3Ptr)) { + objResultPtr = Tcl_DuplicateObj(value3Ptr); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else { + objResultPtr = value3Ptr; + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 4, 1); + case INST_STR_MAP: valuePtr = OBJ_AT_TOS; /* "Main" string. */ value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */ -- cgit v0.12 From 4ee64245d2eac19dc88e6c5c05d4ee1f23d0b6ea Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Dec 2013 17:21:39 +0000 Subject: completed instruction implementation --- generic/tclCompile.c | 4 +++ generic/tclCompile.h | 3 ++- generic/tclExecute.c | 72 +++++++++++++++++++++++++++++++++++++--------------- 3 files changed, 57 insertions(+), 22 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index db97c45..5474535 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -606,6 +606,10 @@ InstructionDesc const tclInstructionTable[] = { /* [string totitle] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ + {"strReplace", 1, -3, 0, {OPERAND_NONE}}, + /* [string replace] core: replaces a non-empty range of one string + * with the contents of another. + * Stack: ... string fromIdx toIdx replacement => ... newString */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6226f7f..207b710 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -784,9 +784,10 @@ typedef struct ByteCode { #define INST_STR_UPPER 174 #define INST_STR_LOWER 175 #define INST_STR_TITLE 176 +#define INST_STR_REPLACE 177 /* The last opcode */ -#define LAST_INST_OPCODE 176 +#define LAST_INST_OPCODE 177 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d178934..3ba252f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5158,30 +5158,41 @@ TEBCresume( Tcl_Obj *value3Ptr; case INST_STR_REPLACE: - valuePtr = OBJ_AT_DEPTH(3); + value3Ptr = POP_OBJECT(); + valuePtr = OBJ_AT_DEPTH(2); length = Tcl_GetCharLength(valuePtr) - 1; - value3Ptr = OBJ_AT_TOS; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), - O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(value3Ptr))); - if (TclGetIntForIndexM(interp, OBJ_AT_DEPTH(2), length, + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, &toIdx) != TCL_OK) { + TclDecrRefCount(value3Ptr); goto gotError; } + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); if (fromIdx < 0) { fromIdx = 0; } if (fromIdx > toIdx || fromIdx > length) { TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(1, 3, 0); + TclDecrRefCount(value3Ptr); + NEXT_INST_F(1, 0, 0); + } + + if (toIdx > length) { + toIdx = length; } if (fromIdx == 0 && toIdx == length) { - objResultPtr = value3Ptr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 4, 1); + TclDecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = value3Ptr; + TRACE_APPEND(("%.30s\n", O2S(value3Ptr))); + NEXT_INST_F(1, 0, 0); } length3 = Tcl_GetCharLength(value3Ptr); @@ -5191,35 +5202,52 @@ TEBCresume( */ if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) { + TclDecrRefCount(value3Ptr); Tcl_SetObjLength(valuePtr, fromIdx); TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(1, 3, 0); + NEXT_INST_F(1, 0, 0); } - // Splice in place. + /* + * See if we can splice in place. This happens when the number of + * characters being replaced is the same as the number of characters + * in the string to be inserted. + */ if (length3 == toIdx - fromIdx) { unsigned char *bytes1, *bytes2; if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_DuplicateObj(valuePtr); - // splice "in place" if (TclIsPureByteArray(objResultPtr) && TclIsPureByteArray(value3Ptr)) { - bytes1 = Tcl_GetByteArrayFromObj(objResultPtr); - bytes2 = Tcl_GetByteArrayFromObj(value3Ptr); + bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); } else { + ustring1 = Tcl_GetUnicode(objResultPtr); + ustring2 = Tcl_GetUnicode(value3Ptr); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); } - NEXT_INST_F(1, 4, 1); + Tcl_InvalidateStringRep(objResultPtr); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); } else { - // splice "in place" if (TclIsPureByteArray(valuePtr) && TclIsPureByteArray(value3Ptr)) { - bytes1 = Tcl_GetByteArrayFromObj(valuePtr); - bytes2 = Tcl_GetByteArrayFromObj(value3Ptr); + bytes1 = Tcl_GetByteArrayFromObj(valuePtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); } else { + ustring1 = Tcl_GetUnicode(valuePtr); + ustring2 = Tcl_GetUnicode(value3Ptr); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); } - NEXT_INST_F(1, 3, 0); + Tcl_InvalidateStringRep(valuePtr); + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); } } @@ -5246,8 +5274,9 @@ TEBCresume( objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, length - toIdx); } + TclDecrRefCount(value3Ptr); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 4, 1); + NEXT_INST_F(1, 1, 1); } /* @@ -5274,8 +5303,9 @@ TEBCresume( length - toIdx); } } + TclDecrRefCount(value3Ptr); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 4, 1); + NEXT_INST_F(1, 1, 1); case INST_STR_MAP: valuePtr = OBJ_AT_TOS; /* "Main" string. */ -- cgit v0.12 From 7a36091c38950f503d0fc9d92468e3f4f41a5b02 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 29 Dec 2013 16:59:15 +0000 Subject: use the new instruction --- generic/tclCompCmdsSZ.c | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 110476e..649a76a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -765,12 +765,25 @@ TclCompileStringReplaceCmd( } else { /* - * Too complicated to optimize, but we know the number of arguments is - * correct so we can issue a call of the "standard" implementation. + * Need to process indices at runtime. This could be because the + * indices are not constants, or because we need to resolve them to + * absolute indices to work out if a replacement is going to happen. + * In any case, to runtime it is. */ genericReplace: - return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + CompileWord(envPtr, valueTokenPtr, interp, 1); + tokenPtr = TokenAfter(valueTokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + if (replacementTokenPtr != NULL) { + CompileWord(envPtr, replacementTokenPtr, interp, 4); + } else { + PUSH( ""); + } + OP( STR_REPLACE); + return TCL_OK; } } -- cgit v0.12 From 7319a7803bdae6ac04ac55fd6701ac2bcadd92f2 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 29 Dec 2013 18:48:09 +0000 Subject: precondition was wrong, and needed to flush part of the string/internal rep --- generic/tclExecute.c | 32 +++++++++++++++++++++++++++----- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3ba252f..bbc3731 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5214,7 +5214,7 @@ TEBCresume( * in the string to be inserted. */ - if (length3 == toIdx - fromIdx) { + if (length3 - 1 == toIdx - fromIdx) { unsigned char *bytes1, *bytes2; if (Tcl_IsShared(valuePtr)) { @@ -5225,10 +5225,21 @@ TEBCresume( bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); memcpy(bytes1 + fromIdx, bytes2, length3); } else { - ustring1 = Tcl_GetUnicode(objResultPtr); - ustring2 = Tcl_GetUnicode(value3Ptr); + ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); memcpy(ustring1 + fromIdx, ustring2, length3 * sizeof(Tcl_UniChar)); + + /* + * Magic! Flush the info in the string internal rep that + * refers to the about-to-be-invalidated UTF-8 rep. This + * sets the 'allocated' field of the String structure to 0 + * to indicate that a new buffer needs to be allocated. + * This is safe; we know we've got a tclStringTypePtr set + * at this point (post Tcl_GetUnicodeFromObj). + */ + + ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; } Tcl_InvalidateStringRep(objResultPtr); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); @@ -5240,10 +5251,21 @@ TEBCresume( bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); memcpy(bytes1 + fromIdx, bytes2, length3); } else { - ustring1 = Tcl_GetUnicode(valuePtr); - ustring2 = Tcl_GetUnicode(value3Ptr); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); memcpy(ustring1 + fromIdx, ustring2, length3 * sizeof(Tcl_UniChar)); + + /* + * Magic! Flush the info in the string internal rep that + * refers to the about-to-be-invalidated UTF-8 rep. This + * sets the 'allocated' field of the String structure to 0 + * to indicate that a new buffer needs to be allocated. + * This is safe; we know we've got a tclStringTypePtr set + * at this point (post Tcl_GetUnicodeFromObj). + */ + + ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; } Tcl_InvalidateStringRep(valuePtr); TRACE_APPEND(("%.30s\n", O2S(valuePtr))); -- cgit v0.12 From f7157671ce93dc1c2a80987e4ebc037cac1b9513 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2013 08:12:52 +0000 Subject: corrected comment --- generic/tclCompCmdsSZ.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 649a76a..c4af5ce 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -700,8 +700,8 @@ TclCompileStringReplaceCmd( /* * We handle these replacements specially: first character (where - * idx1=idx2=0) and suffixes (where idx1=idx2=INDEX_END). Anything else - * and the semantics get rather screwy. + * idx1=idx2=0) and last character (where idx1=idx2=INDEX_END). Anything + * else and the semantics get rather screwy. */ if (idx1 == 0 && idx2 == 0) { -- cgit v0.12 From cdacc33cbbaa19a6840b6de4549153bf33da94e4 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2013 08:16:21 +0000 Subject: allow generation by assembler --- generic/tclAssembly.c | 7 ++++--- generic/tclCompile.c | 8 ++++---- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index cd0a42d..b7bd1cd 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -453,9 +453,9 @@ static const TalInstDesc TalInstructionTable[] = { | INST_STORE_ARRAY4), 2, 1}, {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, - {"strLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, - {"strTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, - {"strUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, + {"strcaseLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, + {"strcaseTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, + {"strcaseUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, @@ -466,6 +466,7 @@ static const TalInstDesc TalInstructionTable[] = { {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, + {"strreplace", ASSEM_1BYTE, INST_STR_REPLACE, 4, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, {"strtrim", ASSEM_1BYTE, INST_STR_TRIM, 2, 1}, {"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1}, diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5474535..4ce5a66 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -594,19 +594,19 @@ InstructionDesc const tclInstructionTable[] = { * is number of values to concatenate. * Operation: push concat(stk1 stk2 ... stktop) */ - {"strUpper", 1, 0, 0, {OPERAND_NONE}}, + {"strcaseUpper", 1, 0, 0, {OPERAND_NONE}}, /* [string toupper] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ - {"strLower", 1, 0, 0, {OPERAND_NONE}}, + {"strcaseLower", 1, 0, 0, {OPERAND_NONE}}, /* [string tolower] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ - {"strTitle", 1, 0, 0, {OPERAND_NONE}}, + {"strcaseTitle", 1, 0, 0, {OPERAND_NONE}}, /* [string totitle] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ - {"strReplace", 1, -3, 0, {OPERAND_NONE}}, + {"strreplace", 1, -3, 0, {OPERAND_NONE}}, /* [string replace] core: replaces a non-empty range of one string * with the contents of another. * Stack: ... string fromIdx toIdx replacement => ... newString */ -- cgit v0.12 From 4ad593f2bfa83036baa51ee39064e8c5f1020e5e Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2013 08:37:49 +0000 Subject: implement [namespace origin] in bytecode --- generic/tclAssembly.c | 1 + generic/tclCompCmdsGR.c | 22 ++++++++++++++++++++++ generic/tclCompile.c | 5 +++++ generic/tclCompile.h | 4 +++- generic/tclExecute.c | 26 ++++++++++++++++++++++++-- generic/tclInt.h | 3 +++ generic/tclNamesp.c | 2 +- 7 files changed, 59 insertions(+), 4 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index b7bd1cd..89c286a 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -437,6 +437,7 @@ static const TalInstDesc TalInstructionTable[] = { {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, + {"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1}, {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, {"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1}, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index fc54620..df8895f 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1956,6 +1956,28 @@ TclCompileNamespaceCodeCmd( } int +TclCompileNamespaceOriginCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr); + return TCL_OK; +} + +int TclCompileNamespaceQualifiersCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 4ce5a66..0732fe5 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -611,6 +611,11 @@ InstructionDesc const tclInstructionTable[] = { * with the contents of another. * Stack: ... string fromIdx toIdx replacement => ... newString */ + {"originCmd", 1, 0, 0, {OPERAND_NONE}}, + /* Reports which command was the origin (via namespace import chain) + * of the command named on the top of the stack. + * Stack: ... cmdName => ... fullOriginalCmdName */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 207b710..fb66e90 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -786,8 +786,10 @@ typedef struct ByteCode { #define INST_STR_TITLE 176 #define INST_STR_REPLACE 177 +#define INST_ORIGIN_COMMAND 178 + /* The last opcode */ -#define LAST_INST_OPCODE 177 +#define LAST_INST_OPCODE 178 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bbc3731..14ff3dd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4402,15 +4402,37 @@ TEBCresume( TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - case INST_RESOLVE_COMMAND: { - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); + { + Tcl_Command cmd, origCmd; + case INST_RESOLVE_COMMAND: + cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); TclNewObj(objResultPtr); if (cmd != NULL) { Tcl_GetCommandFullName(interp, cmd, objResultPtr); } TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); + + case INST_ORIGIN_COMMAND: + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); + if (cmd == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", + TclGetString(OBJ_AT_TOS), NULL); + TRACE_APPEND(("ERROR: not command\n")); + goto gotError; + } + origCmd = TclGetOriginalCommand(cmd); + if (origCmd == NULL) { + origCmd = cmd; + } + TclNewObj(objResultPtr); + Tcl_GetCommandFullName(interp, origCmd, objResultPtr); + TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); + NEXT_INST_F(1, 1, 1); } case INST_TCLOO_SELF: { CallFrame *framePtr = iPtr->varFramePtr; diff --git a/generic/tclInt.h b/generic/tclInt.h index 1ad32df..94ee836 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3571,6 +3571,9 @@ MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceOriginCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index cd44455..8f2f10e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -171,7 +171,7 @@ static const EnsembleImplMap defaultNamespaceMap[] = { {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, - {"origin", NamespaceOriginCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"origin", NamespaceOriginCmd, TclCompileNamespaceOriginCmd, NULL, NULL, 0}, {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, -- cgit v0.12 From 76007824cc7230f1c7cce2fb188eee69a045079a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2013 11:40:44 +0000 Subject: Factor out the definition of the default string trim set; define it once only. --- generic/tclCmdMZ.c | 35 +--------------------------- generic/tclCompCmdsSZ.c | 32 +------------------------- generic/tclStringTrim.h | 61 +++++++++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 5 ++-- 4 files changed, 66 insertions(+), 67 deletions(-) create mode 100644 generic/tclStringTrim.h diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index cefe850..d477216 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -18,6 +18,7 @@ #include "tclInt.h" #include "tclRegexp.h" +#include "tclStringTrim.h" static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); @@ -31,40 +32,6 @@ static int TryPostHandler(ClientData data[], Tcl_Interp *interp, int result); static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); - -/* - * Default set of characters to trim in [string trim] and friends. This is a - * UTF-8 literal string containing all Unicode space characters [TIP #413] - * - * Synch with tclCompCmdsSZ.c - */ - -#define DEFAULT_TRIM_SET \ - "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ - "\xc0\x80" /* nul (U+0000) */\ - "\xc2\x85" /* next line (U+0085) */\ - "\xc2\xa0" /* non-breaking space (U+00a0) */\ - "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ - "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ - "\xe2\x80\x80" /* en quad (U+2000) */\ - "\xe2\x80\x81" /* em quad (U+2001) */\ - "\xe2\x80\x82" /* en space (U+2002) */\ - "\xe2\x80\x83" /* em space (U+2003) */\ - "\xe2\x80\x84" /* three-per-em space (U+2004) */\ - "\xe2\x80\x85" /* four-per-em space (U+2005) */\ - "\xe2\x80\x86" /* six-per-em space (U+2006) */\ - "\xe2\x80\x87" /* figure space (U+2007) */\ - "\xe2\x80\x88" /* punctuation space (U+2008) */\ - "\xe2\x80\x89" /* thin space (U+2009) */\ - "\xe2\x80\x8a" /* hair space (U+200a) */\ - "\xe2\x80\x8b" /* zero width space (U+200b) */\ - "\xe2\x80\xa8" /* line separator (U+2028) */\ - "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ - "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ - "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ - "\xe2\x81\xa0" /* word joiner (U+2060) */\ - "\xe3\x80\x80" /* ideographic space (U+3000) */\ - "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ /* *---------------------------------------------------------------------- diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index c4af5ce..0f2790f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -17,6 +17,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include "tclStringTrim.h" /* * Prototypes for procedures defined later in this file: @@ -787,37 +788,6 @@ TclCompileStringReplaceCmd( } } -/* - * Synch with tclCmdMZ.c - */ - -#define DEFAULT_TRIM_SET \ - "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ - "\xc0\x80" /* nul (U+0000) */\ - "\xc2\x85" /* next line (U+0085) */\ - "\xc2\xa0" /* non-breaking space (U+00a0) */\ - "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ - "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ - "\xe2\x80\x80" /* en quad (U+2000) */\ - "\xe2\x80\x81" /* em quad (U+2001) */\ - "\xe2\x80\x82" /* en space (U+2002) */\ - "\xe2\x80\x83" /* em space (U+2003) */\ - "\xe2\x80\x84" /* three-per-em space (U+2004) */\ - "\xe2\x80\x85" /* four-per-em space (U+2005) */\ - "\xe2\x80\x86" /* six-per-em space (U+2006) */\ - "\xe2\x80\x87" /* figure space (U+2007) */\ - "\xe2\x80\x88" /* punctuation space (U+2008) */\ - "\xe2\x80\x89" /* thin space (U+2009) */\ - "\xe2\x80\x8a" /* hair space (U+200a) */\ - "\xe2\x80\x8b" /* zero width space (U+200b) */\ - "\xe2\x80\xa8" /* line separator (U+2028) */\ - "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ - "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ - "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ - "\xe2\x81\xa0" /* word joiner (U+2060) */\ - "\xe3\x80\x80" /* ideographic space (U+3000) */\ - "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ - int TclCompileStringTrimLCmd( Tcl_Interp *interp, /* Used for error reporting. */ diff --git a/generic/tclStringTrim.h b/generic/tclStringTrim.h new file mode 100644 index 0000000..63544a7 --- /dev/null +++ b/generic/tclStringTrim.h @@ -0,0 +1,61 @@ +/* + * tclStringTrim.h -- + * + * This file contains the definition of what characters are to be trimmed + * from a string by [string trim] by default. It's only needed by Tcl's + * implementation; it does not form a public or private API at all. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-2000 Scriptics Corporation. + * Copyright (c) 2002 ActiveState Corporation. + * Copyright (c) 2003-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. + */ + +#ifndef TCL_STRING_TRIM_H +#define TCL_STRING_TRIM_H + +/* + * Default set of characters to trim in [string trim] and friends. This is a + * UTF-8 literal string containing all Unicode space characters. [TIP #413] + */ + +#define DEFAULT_TRIM_SET \ + "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ + "\xc0\x80" /* nul (U+0000) */\ + "\xc2\x85" /* next line (U+0085) */\ + "\xc2\xa0" /* non-breaking space (U+00a0) */\ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ + "\xe2\x80\x80" /* en quad (U+2000) */\ + "\xe2\x80\x81" /* em quad (U+2001) */\ + "\xe2\x80\x82" /* en space (U+2002) */\ + "\xe2\x80\x83" /* em space (U+2003) */\ + "\xe2\x80\x84" /* three-per-em space (U+2004) */\ + "\xe2\x80\x85" /* four-per-em space (U+2005) */\ + "\xe2\x80\x86" /* six-per-em space (U+2006) */\ + "\xe2\x80\x87" /* figure space (U+2007) */\ + "\xe2\x80\x88" /* punctuation space (U+2008) */\ + "\xe2\x80\x89" /* thin space (U+2009) */\ + "\xe2\x80\x8a" /* hair space (U+200a) */\ + "\xe2\x80\x8b" /* zero width space (U+200b) */\ + "\xe2\x80\xa8" /* line separator (U+2028) */\ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ + "\xe2\x81\xa0" /* word joiner (U+2060) */\ + "\xe3\x80\x80" /* ideographic space (U+3000) */\ + "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ + +#endif /* TCL_STRING_TRIM_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/Makefile.in b/unix/Makefile.in index a0d0c87..2b8e6b9 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1035,6 +1035,7 @@ IOHDR=$(GENERIC_DIR)/tclIO.h MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h PARSEHDR=$(GENERIC_DIR)/tclParse.h NREHDR=$(GENERIC_DIR)/tclInt.h +TRIMHDR=$(GENERIC_DIR)/tclStringTrim.h regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \ $(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \ @@ -1080,7 +1081,7 @@ tclCmdAH.o: $(GENERIC_DIR)/tclCmdAH.c tclCmdIL.o: $(GENERIC_DIR)/tclCmdIL.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdIL.c -tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) +tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdMZ.c tclDate.o: $(GENERIC_DIR)/tclDate.c @@ -1092,7 +1093,7 @@ tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) tclCompCmdsGR.o: $(GENERIC_DIR)/tclCompCmdsGR.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsGR.c -tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) +tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsSZ.c tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c $(COMPILEHDR) -- cgit v0.12 From 413a0c2501a1e8fb04bd3f192513ecee64f941f6 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2013 11:56:54 +0000 Subject: put the other definition of a trim set in the header file too --- generic/tclCompCmds.c | 7 ------- generic/tclStringTrim.h | 7 +++++++ generic/tclUtil.c | 16 ++++++++++------ unix/Makefile.in | 2 +- 4 files changed, 18 insertions(+), 14 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 51ac9ed..05b6d07 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -65,13 +65,6 @@ const AuxDataType tclDictUpdateInfoType = { FreeDictUpdateInfo, /* freeProc */ PrintDictUpdateInfo /* printProc */ }; - -/* - * The definition of what whitespace is stripped when [concat]enating. Must be - * kept in synch with tclUtil.c - */ - -#define CONCAT_WS " \f\v\r\t\n" /* *---------------------------------------------------------------------- diff --git a/generic/tclStringTrim.h b/generic/tclStringTrim.h index 63544a7..669f10b 100644 --- a/generic/tclStringTrim.h +++ b/generic/tclStringTrim.h @@ -50,6 +50,13 @@ "\xe3\x80\x80" /* ideographic space (U+3000) */\ "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ +/* + * The whitespace trimming set used when [concat]enating. This is a subset of + * the above, and deliberately so. + */ + +#define CONCAT_TRIM_SET " \f\v\r\t\n" + #endif /* TCL_STRING_TRIM_H */ /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index b089132..2d00adf 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -14,6 +14,7 @@ #include "tclInt.h" #include "tclParse.h" +#include "tclStringTrim.h" #include /* @@ -1768,8 +1769,7 @@ TclTrimLeft( */ /* The whitespace characters trimmed during [concat] operations */ -#define CONCAT_WS " \f\v\r\t\n" -#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_WS "") - 1) +#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( @@ -1825,7 +1825,8 @@ Tcl_Concat( * Trim away the leading whitespace. */ - trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); element += trim; elemLength -= trim; @@ -1834,7 +1835,8 @@ Tcl_Concat( * a final backslash character. */ - trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; @@ -1959,7 +1961,8 @@ Tcl_ConcatObj( * Trim away the leading whitespace. */ - trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); element += trim; elemLength -= trim; @@ -1968,7 +1971,8 @@ Tcl_ConcatObj( * a final backslash character. */ - trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; diff --git a/unix/Makefile.in b/unix/Makefile.in index 2b8e6b9..71851e6 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1309,7 +1309,7 @@ tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c tclTrace.o: $(GENERIC_DIR)/tclTrace.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTrace.c -tclUtil.o: $(GENERIC_DIR)/tclUtil.c $(PARSEHDR) +tclUtil.o: $(GENERIC_DIR)/tclUtil.c $(PARSEHDR) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.c tclUtf.o: $(GENERIC_DIR)/tclUtf.c $(GENERIC_DIR)/tclUniData.c -- cgit v0.12 From 0891bbbcbb8a9d38d1e5623a90a79561972f79ed Mon Sep 17 00:00:00 2001 From: mig Date: Tue, 31 Dec 2013 12:14:50 +0000 Subject: clarify the resume sequence in TEBCresume; make checkInterp a local variable, remove it from the saved struct --- generic/tclExecute.c | 42 ++++++++++++++---------------------------- 1 file changed, 14 insertions(+), 28 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9261f19..657b5b2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -178,7 +178,6 @@ typedef struct TEBCdata { ptrdiff_t *catchTop; /* this level: they record the state when a */ int cleanup; /* new codePtr was received for NR */ Tcl_Obj *auxObjList; /* execution. */ - int checkInterp; CmdFrame cmdFrame; void *stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as @@ -1992,7 +1991,6 @@ TclNRExecuteByteCode( TD->catchTop = initCatchTop; TD->cleanup = 0; TD->auxObjList = NULL; - TD->checkInterp = 0; /* * TIP #280: Initialize the frame. Do not push it yet: it will be pushed @@ -2078,9 +2076,6 @@ TEBCresume( #define auxObjList (TD->auxObjList) #define catchTop (TD->catchTop) #define codePtr (TD->codePtr) -#define checkInterp (TD->checkInterp) - /* Indicates when a check of interp readyness is - * necessary. Set by CACHE_STACK_INFO() */ /* * Globals: variables that store state, must remain valid at all times. @@ -2098,6 +2093,8 @@ TEBCresume( int cleanup = 0; Tcl_Obj *objResultPtr; + int checkInterp; /* Indicates when a check of interp readyness + * is necessary. Set by CACHE_STACK_INFO() */ /* * Locals - variables that are used within opcodes or bounded sections of @@ -2129,10 +2126,18 @@ TEBCresume( } #endif - if (data[1] /* resume from invocation */) { + if (!data[1]) { + /* bytecode is starting from scratch */ + checkInterp = 0; + goto cleanup0; + } else { + /* resume from invocation */ + CACHE_STACK_INFO(); if (iPtr->execEnvPtr->rewind) { result = TCL_ERROR; + goto abnormalReturn; } + NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); if (bcFramePtr->cmdObj) { Tcl_DecrRefCount(bcFramePtr->cmdObj); @@ -2148,7 +2153,6 @@ TEBCresume( codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; } - CACHE_STACK_INFO(); if (result == TCL_OK) { /* * Push the call's object result and continue execution with the @@ -2180,30 +2184,12 @@ TEBCresume( } #endif NEXT_INST_V(0, cleanup, -1); + } else { + pc--; + goto processExceptionReturn; } - - /* - * Result not TCL_OK: fall through - */ } - if (iPtr->execEnvPtr->rewind) { - result = TCL_ERROR; - goto abnormalReturn; - } - - if (result != TCL_OK) { - pc--; - goto processExceptionReturn; - } - - /* - * Loop executing instructions until a "done" instruction, a TCL_RETURN, - * or some error. - */ - - goto cleanup0; - /* * Targets for standard instruction endings; unrolled for speed in the * most frequent cases (instructions that consume up to two stack -- cgit v0.12 From c45f1130d1a169b181c45ba4bc6ce954746a3239 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Dec 2013 16:26:55 +0000 Subject: more peephole optimizations in TEBC, and better instruction execution traces --- generic/tclExecute.c | 360 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 212 insertions(+), 148 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 657b5b2..6d98cea 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -384,6 +384,8 @@ VarHashCreateVar( printf a; \ break; \ } +# define TRACE_ERROR(interp) \ + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ while (traceInstructions) { \ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ @@ -400,6 +402,7 @@ VarHashCreateVar( #else /* !TCL_COMPILE_DEBUG */ # define TRACE(a) # define TRACE_APPEND(a) +# define TRACE_ERROR(interp) # define TRACE_WITH_OBJ(a, objPtr) # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ @@ -2745,9 +2748,9 @@ TEBCresume( */ objPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(objPtr))); if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } (void) POP_OBJECT(); @@ -2791,6 +2794,7 @@ TEBCresume( PUSH_OBJECT(objv[i]); } + TRACE_APPEND(("OK\n")); Tcl_DecrRefCount(objPtr); NEXT_INST_F(5, 0, 0); } @@ -3135,7 +3139,7 @@ TEBCresume( varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } cleanup = 1; @@ -3161,7 +3165,7 @@ TEBCresume( TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1, &arrayPtr); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } @@ -3188,7 +3192,7 @@ TEBCresume( part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); @@ -3337,7 +3341,7 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } cleanup = ((part2Ptr == NULL)? 2 : 3); @@ -3387,7 +3391,7 @@ TEBCresume( varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } goto doCallPtrSetVar; @@ -3435,7 +3439,7 @@ TEBCresume( part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); CACHE_STACK_INFO(); if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } #ifndef TCL_COMPILE_DEBUG @@ -3512,7 +3516,7 @@ TEBCresume( if (!varPtr) { Tcl_AddErrorInfo(interp, "\n (reading value of variable to increment)"); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; } @@ -3538,7 +3542,7 @@ TEBCresume( varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; } @@ -3650,8 +3654,7 @@ TEBCresume( TclNewLongObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } Tcl_DecrRefCount(incrPtr); @@ -3688,8 +3691,7 @@ TEBCresume( } if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } Tcl_DecrRefCount(incrPtr); @@ -3700,8 +3702,7 @@ TEBCresume( CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -3722,6 +3723,8 @@ TEBCresume( */ case INST_EXIST_SCALAR: + cleanup = 0; + pcAdjustment = 5; opnd = TclGetUInt4AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -3738,16 +3741,11 @@ TEBCresume( varPtr = NULL; } } - - /* - * Tricky! Arrays always exist. - */ - - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 0, 1); + goto afterExistsPeephole; case INST_EXIST_ARRAY: + cleanup = 1; + pcAdjustment = 5; opnd = TclGetUInt4AtPtr(pc+1); part2Ptr = OBJ_AT_TOS; arrayPtr = LOCAL(opnd); @@ -3758,7 +3756,7 @@ TEBCresume( if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (!varPtr || !ReadTraced(varPtr)) { - goto doneExistArray; + goto afterExistsPeephole; } } varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", @@ -3775,13 +3773,11 @@ TEBCresume( varPtr = NULL; } } - doneExistArray: - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 1, 1); + goto afterExistsPeephole; case INST_EXIST_ARRAY_STK: cleanup = 2; + pcAdjustment = 1; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); @@ -3789,6 +3785,7 @@ TEBCresume( case INST_EXIST_STK: cleanup = 1; + pcAdjustment = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ TRACE(("\"%.30s\" => ", O2S(part1Ptr))); @@ -3808,9 +3805,31 @@ TEBCresume( varPtr = NULL; } } - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); + + /* + * Peep-hole optimisation: if you're about to jump, do jump from here. + */ + + afterExistsPeephole: { + int found = (varPtr && !TclIsVarUndefined(varPtr)); + + pc += pcAdjustment; +#ifndef TCL_COMPILE_DEBUG + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_V((found? 2 : TclGetInt1AtPtr(pc+1)), cleanup, 0); + case INST_JUMP_TRUE1: + NEXT_INST_V((found? TclGetInt1AtPtr(pc+1) : 2), cleanup, 0); + case INST_JUMP_FALSE4: + NEXT_INST_V((found? 5 : TclGetInt4AtPtr(pc+1)), cleanup, 0); + case INST_JUMP_TRUE4: + NEXT_INST_V((found? TclGetInt4AtPtr(pc+1) : 5), cleanup, 0); + } +#endif + objResultPtr = TCONST(found ? 1 : 0); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(1, cleanup, 1); + NEXT_INST_V(0, cleanup, 1); + } /* * End of INST_EXIST instructions. @@ -3828,7 +3847,7 @@ TEBCresume( while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd)); + TRACE(("%s %u => ", (flags?"normal":"noerr"), opnd)); if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { /* * No errors, no traces, no searches: just make the variable cease @@ -3841,6 +3860,7 @@ TEBCresume( goto slowUnsetScalar; } varPtr->value.objPtr = NULL; + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 0, 0); } @@ -3861,7 +3881,7 @@ TEBCresume( while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%s %u \"%.30s\"\n", + TRACE(("%s %u \"%.30s\" => ", (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); @@ -3877,12 +3897,14 @@ TEBCresume( goto slowUnsetArray; } varPtr->value.objPtr = NULL; + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 1, 0); } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { /* * Don't need to do anything here. */ + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 1, 0); } } @@ -3906,7 +3928,7 @@ TEBCresume( cleanup = 2; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"), + TRACE(("%s \"%.30s(%.30s)\" => ", (flags?"normal":"noerr"), O2S(part1Ptr), O2S(part2Ptr))); goto doUnsetStk; @@ -3915,7 +3937,7 @@ TEBCresume( cleanup = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr))); + TRACE(("%s \"%.30s\" => ", (flags?"normal":"noerr"), O2S(part1Ptr))); doUnsetStk: DECACHE_STACK_INFO(); @@ -3924,11 +3946,12 @@ TEBCresume( goto errorInUnset; } CACHE_STACK_INFO(); + TRACE_APPEND(("OK\n")); NEXT_INST_V(2, cleanup, 0); errorInUnset: CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; /* @@ -3990,8 +4013,7 @@ TEBCresume( TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); CACHE_STACK_INFO(); if (result == TCL_ERROR) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -4024,7 +4046,7 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } doArrayMake: @@ -4037,8 +4059,7 @@ TEBCresume( TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", "variable isn't array", opnd); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); - TRACE_APPEND(("ERROR: bad array ref: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TclSetVarArray(varPtr); @@ -4066,9 +4087,11 @@ TEBCresume( Namespace *savedNsPtr; case INST_UPVAR: - TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); + TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { + TRACE_ERROR(interp); goto gotError; } @@ -4083,13 +4106,16 @@ TEBCresume( /*createPart2*/ 1, &varPtr); iPtr->varFramePtr = savedFramePtr; if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } goto doLinkVars; case INST_NSUPVAR: - TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); + TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4104,16 +4130,18 @@ TEBCresume( /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); iPtr->varFramePtr->nsPtr = savedNsPtr; if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } goto doLinkVars; case INST_VARIABLE: - TRACE(("variable ")); + TRACE(("%d, %.30s => ", TclGetInt4AtPtr(pc+1), O2S(OBJ_AT_TOS))); otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } @@ -4131,7 +4159,7 @@ TEBCresume( * if there are no errors; otherwise, let it handle the case. */ - opnd = TclGetInt4AtPtr(pc+1);; + opnd = TclGetInt4AtPtr(pc+1); varPtr = LOCAL(opnd); if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { @@ -4143,6 +4171,7 @@ TEBCresume( Var *linkPtr = varPtr->value.linkPtr; if (linkPtr == otherPtr) { + TRACE_APPEND(("already linked\n")); NEXT_INST_F(5, 1, 0); } if (TclIsVarInHash(linkPtr)) { @@ -4159,6 +4188,7 @@ TEBCresume( } } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4167,6 +4197,7 @@ TEBCresume( * variables - and [variable] did not push it at all. */ + TRACE_APPEND(("link made\n")); NEXT_INST_F(5, 1, 0); } @@ -4213,31 +4244,29 @@ TEBCresume( doCondJump: valuePtr = OBJ_AT_TOS; + TRACE(("%d => ", jmpOffset[ + (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE4) ? 0 : 1])); /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { - TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[ - ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) - ? 0 : 1]), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } #ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], - O2S(valuePtr), + TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr), (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); } else { - TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); + TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } } else { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); + TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { - TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], - O2S(valuePtr), + TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr), (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); } } @@ -4256,7 +4285,7 @@ TEBCresume( opnd = TclGetInt4AtPtr(pc+1); jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS))); + TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); if (hPtr != NULL) { int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); @@ -4351,9 +4380,8 @@ TEBCresume( register CallFrame *framePtr = iPtr->varFramePtr; register CallFrame *rootFramePtr = iPtr->rootFramePtr; - valuePtr = OBJ_AT_TOS; - if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(OBJ_AT_TOS)), Tcl_GetObjResult(interp)); goto gotError; } @@ -4366,11 +4394,11 @@ TEBCresume( /* Empty loop body */ } if (framePtr == rootFramePtr) { - Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr), - "\"", NULL); - TRACE_APPEND(("ERROR: bad level\n")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(OBJ_AT_TOS))); + TRACE_ERROR(interp); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", - TclGetString(valuePtr), NULL); + TclGetString(OBJ_AT_TOS), NULL); goto gotError; } objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); @@ -4466,19 +4494,19 @@ TEBCresume( NEXT_INST_V(5, opnd, 1); case INST_LIST_LENGTH: - valuePtr = OBJ_AT_TOS; - if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + TRACE_APPEND(("%d\n", length)); NEXT_INST_F(1, 1, 1); case INST_LIST_INDEX: /* lindex with objc == 3 */ value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); /* * Extract the desired list element. @@ -4496,8 +4524,7 @@ TEBCresume( objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); if (!objResultPtr) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4505,8 +4532,7 @@ TEBCresume( * Stash the list element on the stack. */ - TRACE(("%.20s %.20s => %s\n", - O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */ case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode @@ -4518,6 +4544,7 @@ TEBCresume( valuePtr = OBJ_AT_TOS; opnd = TclGetInt4AtPtr(pc+1); + TRACE(("\%.30s\" %d => ", O2S(valuePtr), opnd)); /* * Get the contents of the list, making sure that it really is a list @@ -4525,8 +4552,7 @@ TEBCresume( */ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4549,8 +4575,7 @@ TEBCresume( TclNewObj(objResultPtr); } - TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), - objResultPtr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(pcAdjustment, 1, 1); case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ @@ -4565,10 +4590,11 @@ TEBCresume( * Do the 'lindex' operation. */ + TRACE(("%d => ", opnd)); objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), numIndices, &OBJ_AT_DEPTH(numIndices - 1)); if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4576,7 +4602,7 @@ TEBCresume( * Set result. */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd, -1); case INST_LSET_FLAT: @@ -4586,6 +4612,7 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc + 1); numIndices = opnd - 2; + TRACE(("%d => ", opnd)); /* * Get the old value of variable, and remove the stack ref. This is @@ -4604,7 +4631,7 @@ TEBCresume( objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4612,7 +4639,7 @@ TEBCresume( * Set result. */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, numIndices+1, -1); case INST_LSET_LIST: /* 'lset' with 4 args */ @@ -4632,6 +4659,8 @@ TEBCresume( valuePtr = OBJ_AT_TOS; value2Ptr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", + O2S(value2Ptr), O2S(valuePtr), O2S(objPtr))); /* * Compute the new variable value. @@ -4639,8 +4668,7 @@ TEBCresume( objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); if (!objResultPtr) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4648,7 +4676,7 @@ TEBCresume( * Set result. */ - TRACE(("=> %s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in @@ -4661,6 +4689,8 @@ TEBCresume( valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); + TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), + TclGetInt4AtPtr(pc+5))); /* * Get the contents of the list, making sure that it really is a list @@ -4668,8 +4698,7 @@ TEBCresume( */ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), - fromIdx, toIdx), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4726,8 +4755,6 @@ TEBCresume( List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; if (listPtr->refCount == 1) { - TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); for (index=toIdx+1; index ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr); + TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); case INST_LIST_IN: @@ -4753,9 +4779,9 @@ TEBCresume( valuePtr = OBJ_UNDER_TOS; s1 = TclGetStringFromObj(valuePtr, &s1len); + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } match = 0; @@ -4786,7 +4812,7 @@ TEBCresume( match = !match; } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -4818,7 +4844,7 @@ TEBCresume( objResultPtr = Tcl_DuplicateObj(valuePtr); if (Tcl_ListObjAppendList(interp, objResultPtr, value2Ptr) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); TclDecrRefCount(objResultPtr); goto gotError; } @@ -4826,7 +4852,7 @@ TEBCresume( NEXT_INST_F(1, 2, 1); } else { if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){ - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); @@ -4980,6 +5006,7 @@ TEBCresume( case INST_STR_INDEX: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr))); /* * Get char length to calulate what 'end' means. @@ -4987,6 +5014,7 @@ TEBCresume( length = Tcl_GetCharLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -5012,18 +5040,18 @@ TEBCresume( objResultPtr = Tcl_NewStringObj(buf, length); } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); + TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); case INST_STR_RANGE: - TRACE(("\"%.20s\" %s %s =>", + TRACE(("\"%.20s\" %.20s %.20s =>", O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, &fromIdx) != TCL_OK || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, &toIdx) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -5626,8 +5654,7 @@ TEBCresume( TRACE_APPEND(("DIVIDE BY ZERO\n")); goto divideByZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); @@ -5799,8 +5826,7 @@ TEBCresume( TRACE_APPEND(("EXPONENT OF ZERO\n")); goto exponOfZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); @@ -6055,6 +6081,7 @@ TEBCresume( */ opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; @@ -6081,8 +6108,8 @@ TEBCresume( listVarPtr = LOCAL(listTmpIndex); listPtr = listVarPtr->value.objPtr; if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n", + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } if (listLen > iterNum * numVars) { @@ -6137,9 +6164,9 @@ TEBCresume( if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); + TRACE_APPEND(( + "ERROR init. index temp %d: %s\n", + varIndex, O2S(Tcl_GetObjResult(interp)))); TclDecrRefCount(listPtr); goto gotError; } @@ -6151,7 +6178,7 @@ TEBCresume( listTmpIndex++; } } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, + TRACE_APPEND(("%d lists, iter %d, %s loop\n", opnd, numLists, iterNum, (continueLoop? "continue" : "exit"))); /* @@ -6320,10 +6347,14 @@ TEBCresume( NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); } +#ifdef TCL_COMPILE_DEBUG + NEXT_INST_F(1, 0, 0); +#else /* * FALL THROUGH */ pc++; +#endif case INST_FOREACH_END: /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */ @@ -6440,6 +6471,7 @@ TEBCresume( case INST_DICT_GET: case INST_DICT_EXISTS: { register Tcl_Interp *interp2 = interp; + register int found; opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); @@ -6452,7 +6484,8 @@ TEBCresume( &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); if (dictPtr == NULL) { if (*pc == INST_DICT_EXISTS) { - goto dictNotExists; + found = 0; + goto afterDictExists; } TRACE_WITH_OBJ(( "ERROR tracing dictionary path into \"%s\": ", @@ -6464,34 +6497,56 @@ TEBCresume( if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { if (*pc == INST_DICT_EXISTS) { - objResultPtr = TCONST(objResultPtr ? 1 : 0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + found = (objResultPtr ? 1 : 0); + goto afterDictExists; } - if (objResultPtr) { - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + if (!objResultPtr) { + DECACHE_STACK_INFO(); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; } - DECACHE_STACK_INFO(); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } else if (*pc != INST_DICT_EXISTS) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; } else { - if (*pc == INST_DICT_EXISTS) { - dictNotExists: - objResultPtr = TCONST(0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - TRACE_WITH_OBJ(( - "%u => ERROR reading leaf dictionary key \"%s\": ", - opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); + found = 0; } - goto gotError; + afterDictExists: +#ifndef TCL_COMPILE_DEBUG + /* + * The INST_DICT_EXISTS instruction is usually followed by a + * conditional jump, so we can take advantage of this to do some + * peephole optimization (note that we're careful to not close out + * someone doing something else). + */ + + pc += 5; + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_V((found ? 2 : TclGetInt1AtPtr(pc+1)), opnd+1, 0); + case INST_JUMP_FALSE4: + NEXT_INST_V((found ? 5 : TclGetInt4AtPtr(pc+1)), opnd+1, 0); + case INST_JUMP_TRUE1: + NEXT_INST_V((found ? TclGetInt1AtPtr(pc+1) : 2), opnd+1, 0); + case INST_JUMP_TRUE4: + NEXT_INST_V((found ? TclGetInt4AtPtr(pc+1) : 5), opnd+1, 0); + default: + pc -= 5; + /* fall through to non-debug handling */ + } +#endif + TRACE_APPEND(("%d\n", found)); + objResultPtr = TCONST(found); + NEXT_INST_V(5, opnd+1, 1); } case INST_DICT_SET: @@ -6588,8 +6643,7 @@ TEBCresume( CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -6598,7 +6652,7 @@ TEBCresume( NEXT_INST_V(10, cleanup, 0); } #endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(9, cleanup, 1); case INST_DICT_APPEND: @@ -6631,6 +6685,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } @@ -6679,6 +6734,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); @@ -6688,6 +6744,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } @@ -6724,8 +6781,7 @@ TEBCresume( CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -6745,6 +6801,7 @@ TEBCresume( if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, &done) != TCL_OK) { ckfree(searchPtr); + TRACE_ERROR(interp); goto gotError; } TclNewObj(statePtr); @@ -6814,12 +6871,12 @@ TEBCresume( case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", opnd)); varPtr = LOCAL(opnd); duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => \n", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { @@ -6828,11 +6885,13 @@ TEBCresume( TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (dictPtr == NULL) { + TRACE_ERROR(interp); goto gotError; } } if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } if (length != duiPtr->length) { @@ -6841,6 +6900,7 @@ TEBCresume( for (i=0 ; ivarIndices[i]); @@ -6856,21 +6916,23 @@ TEBCresume( valuePtr, TCL_LEAVE_ERR_MSG, duiPtr->varIndices[i]) == NULL) { CACHE_STACK_INFO(); + TRACE_ERROR(interp); goto gotError; } CACHE_STACK_INFO(); } + TRACE_APPEND(("OK\n")); NEXT_INST_F(9, 0, 0); case INST_DICT_UPDATE_END: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", opnd)); varPtr = LOCAL(opnd); duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { @@ -6879,11 +6941,13 @@ TEBCresume( CACHE_STACK_INFO(); } if (dictPtr == NULL) { + TRACE_APPEND(("storage was unset\n")); NEXT_INST_F(9, 1, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } allocdict = Tcl_IsShared(dictPtr); @@ -6929,26 +6993,26 @@ TEBCresume( if (allocdict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } } + TRACE_APPEND(("written back\n")); NEXT_INST_F(9, 1, 0); case INST_DICT_EXPAND: dictPtr = OBJ_UNDER_TOS; listPtr = OBJ_AT_TOS; + TRACE(("%.30s %.30s =>", O2S(dictPtr), O2S(listPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } - TRACE((" => ")); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); @@ -6959,14 +7023,14 @@ TEBCresume( TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); TclDecrRefCount(keysPtr); goto gotError; } varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); TclDecrRefCount(keysPtr); goto gotError; } @@ -6976,7 +7040,7 @@ TEBCresume( CACHE_STACK_INFO(); TclDecrRefCount(keysPtr); if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("OK\n")); @@ -6990,7 +7054,7 @@ TEBCresume( TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), O2S(keysPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } while (TclIsVarLink(varPtr)) { @@ -7001,7 +7065,7 @@ TEBCresume( objc, objv, keysPtr); CACHE_STACK_INFO(); if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("OK\n")); -- cgit v0.12 From d423ce0c062ae90e1050d33f82905f377b70f728 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Dec 2013 17:28:16 +0000 Subject: more cleaning up of error-case instruction tracing --- generic/tclExecute.c | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 82808f6..82daad7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4391,12 +4391,11 @@ TEBCresume( register CallFrame *framePtr = iPtr->varFramePtr; register CallFrame *rootFramePtr = iPtr->rootFramePtr; + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(OBJ_AT_TOS)), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } - TRACE(("%d => ", level)); if (level <= 0) { level += framePtr->level; } @@ -5204,6 +5203,7 @@ TEBCresume( || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, &toIdx) != TCL_OK) { TclDecrRefCount(value3Ptr); + TRACE_ERROR(interp); goto gotError; } TclDecrRefCount(OBJ_AT_TOS); @@ -5587,6 +5587,7 @@ TEBCresume( cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); /* * Compile and match the regular expression. @@ -5597,23 +5598,17 @@ TEBCresume( Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); if (regExpr == NULL) { - goto regexpFailure; + TRACE_ERROR(interp); + goto gotError; } - match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - if (match < 0) { - regexpFailure: -#ifdef TCL_COMPILE_DEBUG - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); -#endif + TRACE_ERROR(interp); goto gotError; } } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. -- cgit v0.12 From f9dd75e79c423909b22ef0aaaee246b7e8960fc6 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Dec 2013 23:34:57 +0000 Subject: another jump peephole, this time with string comparisons --- generic/tclExecute.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6d98cea..c7d0918 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4987,6 +4987,20 @@ TEBCresume( break; } } + +#ifndef TCL_COMPILE_DEBUG + switch (*(pc+1)) { + case INST_JUMP_FALSE1: + NEXT_INST_F((match? 3 : TclGetInt1AtPtr(pc+2)+1), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((match? TclGetInt1AtPtr(pc+2)+1 : 3), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((match? 6 : TclGetInt4AtPtr(pc+2)+1), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((match? TclGetInt4AtPtr(pc+2)+1 : 6), 2, 0); + } +#endif + if (match < 0) { TclNewIntObj(objResultPtr, -1); } else { -- cgit v0.12 From 1c54736c0d3a9fa230bf04a8594b8e5ceb4734d2 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 Jan 2014 16:19:14 +0000 Subject: factor out a common peephole stanza --- generic/tclExecute.c | 216 +++++++++++++++++++-------------------------------- 1 file changed, 79 insertions(+), 137 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c7d0918..411cb8b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -319,6 +319,70 @@ VarHashCreateVar( } \ } while (0) +#ifndef TCL_COMPILE_DEBUG +#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ + do { \ + pc += (pcAdjustment); \ + switch (*pc) { \ + case INST_JUMP_FALSE1: \ + NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE1: \ + NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE4: \ + NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE4: \ + NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F(0, (cleanup), 1); \ + } \ + } while (0) +#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ + do { \ + pc += (pcAdjustment); \ + switch (*pc) { \ + case INST_JUMP_FALSE1: \ + NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE1: \ + NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE4: \ + NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE4: \ + NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V(0, (cleanup), 1); \ + } \ + } while (0) +#else /* TCL_COMPILE_DEBUG */ +#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ + do{ \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F((pcAdjustment), (cleanup), 1); \ + } while (0) +#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ + do{ \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V((pcAdjustment), (cleanup), 1); \ + } while (0) +#endif + /* * Macros used to cache often-referenced Tcl evaluation stack information * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() @@ -3813,22 +3877,8 @@ TEBCresume( afterExistsPeephole: { int found = (varPtr && !TclIsVarUndefined(varPtr)); - pc += pcAdjustment; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_V((found? 2 : TclGetInt1AtPtr(pc+1)), cleanup, 0); - case INST_JUMP_TRUE1: - NEXT_INST_V((found? TclGetInt1AtPtr(pc+1) : 2), cleanup, 0); - case INST_JUMP_FALSE4: - NEXT_INST_V((found? 5 : TclGetInt4AtPtr(pc+1)), cleanup, 0); - case INST_JUMP_TRUE4: - NEXT_INST_V((found? TclGetInt4AtPtr(pc+1) : 5), cleanup, 0); - } -#endif - objResultPtr = TCONST(found ? 1 : 0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(0, cleanup, 1); + TRACE_APPEND(("%d\n", found ? 1 : 0)); + JUMP_PEEPHOLE_V(found, pcAdjustment, cleanup); } /* @@ -4820,21 +4870,7 @@ TEBCresume( * for branching. */ - pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match ? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + JUMP_PEEPHOLE_F(match, 1, 2); case INST_LIST_CONCAT: value2Ptr = OBJ_AT_TOS; @@ -4988,27 +5024,10 @@ TEBCresume( } } -#ifndef TCL_COMPILE_DEBUG - switch (*(pc+1)) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 3 : TclGetInt1AtPtr(pc+2)+1), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+2)+1 : 3), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 6 : TclGetInt4AtPtr(pc+2)+1), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+2)+1 : 6), 2, 0); - } -#endif + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), + (match < 0 ? -1 : match > 0 : 1 : 0))); - if (match < 0) { - TclNewIntObj(objResultPtr, -1); - } else { - objResultPtr = TCONST(match > 0); - } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: valuePtr = OBJ_AT_TOS; @@ -5268,21 +5287,7 @@ TEBCresume( * Peep-hole optimisation: if you're about to jump, do jump from here. */ - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + JUMP_PEEPHOLE_F(match, 2, 2); case INST_REGEXP: cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ @@ -5321,21 +5326,7 @@ TEBCresume( * Adjustment is 2 due to the nocase byte. */ - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + JUMP_PEEPHOLE_F(match, 2, 2); } /* @@ -5433,21 +5424,7 @@ TEBCresume( */ foundResult: - pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(iResult); - NEXT_INST_F(0, 2, 1); + JUMP_PEEPHOLE_F(iResult, 1, 2); } case INST_MOD: @@ -6535,7 +6512,8 @@ TEBCresume( found = 0; } afterDictExists: -#ifndef TCL_COMPILE_DEBUG + TRACE_APPEND(("%d\n", found)); + /* * The INST_DICT_EXISTS instruction is usually followed by a * conditional jump, so we can take advantage of this to do some @@ -6543,24 +6521,7 @@ TEBCresume( * someone doing something else). */ - pc += 5; - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_V((found ? 2 : TclGetInt1AtPtr(pc+1)), opnd+1, 0); - case INST_JUMP_FALSE4: - NEXT_INST_V((found ? 5 : TclGetInt4AtPtr(pc+1)), opnd+1, 0); - case INST_JUMP_TRUE1: - NEXT_INST_V((found ? TclGetInt1AtPtr(pc+1) : 2), opnd+1, 0); - case INST_JUMP_TRUE4: - NEXT_INST_V((found ? TclGetInt4AtPtr(pc+1) : 5), opnd+1, 0); - default: - pc -= 5; - /* fall through to non-debug handling */ - } -#endif - TRACE_APPEND(("%d\n", found)); - objResultPtr = TCONST(found); - NEXT_INST_V(5, opnd+1, 1); + JUMP_PEEPHOLE_V(found, 5, opnd+1); } case INST_DICT_SET: @@ -6851,8 +6812,9 @@ TEBCresume( PUSH_OBJECT(valuePtr); PUSH_OBJECT(keyPtr); } + TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); -#ifndef TCL_COMPILE_DEBUG /* * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always * followed by a conditional jump, so we can take advantage of this to @@ -6860,27 +6822,7 @@ TEBCresume( * out someone doing something else). */ - pc += 5; - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((done ? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((done ? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((done ? TclGetInt1AtPtr(pc+1) : 2), 0, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((done ? TclGetInt4AtPtr(pc+1) : 5), 0, 0); - default: - pc -= 5; - /* fall through to non-debug handling */ - } -#endif - - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); - objResultPtr = TCONST(done); - /* TODO: consider opt like INST_FOREACH_STEP4 */ - NEXT_INST_F(5, 0, 1); + JUMP_PEEPHOLE_F(done, 5, 0); case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); -- cgit v0.12 From 4f13f826e4930cb99d5ddbbaa78a34508f578e4e Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 2 Jan 2014 03:10:43 +0000 Subject: more fixes to instruction tracing; ensure all places that need DECACHE_STACK_INFO have it. jan.nijtmans: Branch moved aside an hidden, so future bisects are not affected by this branch mistakes. --- generic/tclExecute.c | 213 +++++++++++++++++++++++++++++---------------------- 1 file changed, 123 insertions(+), 90 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 411cb8b..37588c5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2220,41 +2220,41 @@ TEBCresume( codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; } - if (result == TCL_OK) { - /* - * Push the call's object result and continue execution with the - * next instruction. - */ + if (result != TCL_OK) { + pc--; + goto processExceptionReturn; + } - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); + /* + * Push the call's object result and continue execution with the next + * instruction. + */ - /* - * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult to - * avoid any side effects caused by the resetting of errorInfo and - * errorCode [Bug 804681], which are not needed here. We chose - * instead to manipulate the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it keeps - * the refCount it had in its role of iPtr->objResultPtr. - */ + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); - objResultPtr = Tcl_GetObjResult(interp); - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; + /* + * Reset the interp's result to avoid possible duplications of large + * objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any + * side effects caused by the resetting of errorInfo and errorCode + * [Bug 804681], which are not needed here. We chose instead to + * manipulate the interp's object result directly. + * + * Note that the result object is now in objResultPtr, it keeps the + * refCount it had in its role of iPtr->objResultPtr. + */ + + objResultPtr = Tcl_GetObjResult(interp); + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; #ifndef TCL_COMPILE_DEBUG - if (*pc == INST_POP) { - TclDecrRefCount(objResultPtr); - NEXT_INST_V(1, cleanup, 0); - } -#endif - NEXT_INST_V(0, cleanup, -1); - } else { - pc--; - goto processExceptionReturn; + if (*pc == INST_POP) { + TclDecrRefCount(objResultPtr); + NEXT_INST_V(1, cleanup, 0); } +#endif + NEXT_INST_V(0, cleanup, -1); } /* @@ -2474,8 +2474,10 @@ TEBCresume( TRACE_APPEND(("ERROR: yield outside coroutine\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "yield can only be called in a coroutine", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); + CACHE_STACK_INFO(); goto gotError; } @@ -2520,7 +2522,9 @@ TEBCresume( TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc or lambda", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + CACHE_STACK_INFO(); goto gotError; } @@ -2598,7 +2602,7 @@ TEBCresume( case INST_OVER: opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = OBJ_AT_DEPTH(opnd); - TRACE_WITH_OBJ(("=> "), objResultPtr); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_F(5, 0, 1); case INST_REVERSE: { @@ -2613,6 +2617,7 @@ TEBCresume( *b = tmpPtr; a++; b--; } + TRACE(("%u => OK\n", opnd)); NEXT_INST_F(5, 0, 0); } @@ -2783,6 +2788,7 @@ TEBCresume( objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); + TRACE(("=> mark depth as %d\n", CURR_DEPTH)); NEXT_INST_F(1, 0, 0); case INST_EXPAND_DROP: @@ -2799,6 +2805,7 @@ TEBCresume( /* Ugly abuse! */ starting = 1; #endif + TRACE(("=> drop %d items\n", objc)); NEXT_INST_V(1, objc, 0); case INST_EXPAND_STKTOP: { @@ -3578,8 +3585,10 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr); if (!varPtr) { + DECACHE_STACK_INFO(); Tcl_AddErrorInfo(interp, "\n (reading value of variable to increment)"); + CACHE_STACK_INFO(); TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; @@ -3897,7 +3906,7 @@ TEBCresume( while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%s %u => ", (flags?"normal":"noerr"), opnd)); + TRACE(("%s %u => ", (flags ? "normal" : "noerr"), opnd)); if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { /* * No errors, no traces, no searches: just make the variable cease @@ -3978,7 +3987,7 @@ TEBCresume( cleanup = 2; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("%s \"%.30s(%.30s)\" => ", (flags?"normal":"noerr"), + TRACE(("%s \"%.30s(%.30s)\" => ", (flags ? "normal" : "noerr"), O2S(part1Ptr), O2S(part2Ptr))); goto doUnsetStk; @@ -3987,7 +3996,8 @@ TEBCresume( cleanup = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("%s \"%.30s\" => ", (flags?"normal":"noerr"), O2S(part1Ptr))); + TRACE(("%s \"%.30s\" => ", (flags ? "normal" : "noerr"), + O2S(part1Ptr))); doUnsetStk: DECACHE_STACK_INFO(); @@ -4010,7 +4020,7 @@ TEBCresume( case INST_DICT_DONE: opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u\n", opnd)); + TRACE(("%u => OK\n", opnd)); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -4108,7 +4118,9 @@ TEBCresume( TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", "variable isn't array", opnd); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } @@ -4447,8 +4459,10 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(OBJ_AT_TOS))); TRACE_ERROR(interp); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); goto gotError; } objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); @@ -4475,7 +4489,9 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_NewStringObj( "self may only be called from inside a method", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + CACHE_STACK_INFO(); goto gotError; } contextPtr = framePtr->clientData; @@ -5024,16 +5040,15 @@ TEBCresume( } } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), + TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), (match < 0 ? -1 : match > 0 : 1 : 0))); - JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); case INST_STR_INDEX: @@ -5150,27 +5165,27 @@ TEBCresume( value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */ if (value3Ptr == value2Ptr) { objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } else if (valuePtr == value2Ptr) { objResultPtr = value3Ptr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); if (length == 0) { objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); if (length2 > length || length2 == 0) { objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } else if (length2 == length) { if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { objResultPtr = valuePtr; } else { objResultPtr = value3Ptr; } - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); @@ -5199,6 +5214,7 @@ TEBCresume( Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); } + doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); NEXT_INST_V(1, 3, 1); @@ -5221,7 +5237,6 @@ TEBCresume( TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); @@ -5293,6 +5308,7 @@ TEBCresume( cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ + TRACE(("%.20s %.20s => ", O2S(valuePtr), O2S(value2Ptr))); /* * Compile and match the regular expression. @@ -5303,23 +5319,17 @@ TEBCresume( Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); if (regExpr == NULL) { - goto regexpFailure; + TRACE_ERROR(interp); + goto gotError; } - match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - if (match < 0) { - regexpFailure: -#ifdef TCL_COMPILE_DEBUG - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); -#endif + TRACE_ERROR(interp); goto gotError; } } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -5424,6 +5434,8 @@ TEBCresume( */ foundResult: + TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), + iResult)); JUMP_PEEPHOLE_F(iResult, 1, 2); } @@ -5511,13 +5523,13 @@ TEBCresume( if (l2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); -#if 0 +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); -#endif +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else if (l1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); @@ -5559,13 +5571,13 @@ TEBCresume( if (l2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); -#if 0 +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); -#endif +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else if (l1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); @@ -5582,12 +5594,12 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); -#if 0 +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", NULL); CACHE_STACK_INFO(); -#endif +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else { int shift = (int) l2; @@ -5835,7 +5847,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), + TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5844,18 +5856,20 @@ TEBCresume( } /* TODO: Consider peephole opt. */ objResultPtr = TCONST(!b); + TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 1, 1); } case INST_BITNOT: valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) { /* * ... ~$NonInteger => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5866,23 +5880,28 @@ TEBCresume( l1 = *((const long *) ptr1); if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, ~l1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } TclSetLongObj(valuePtr, ~l1); + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } case INST_UMINUS: valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s \n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5892,23 +5911,28 @@ TEBCresume( switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); case TCL_NUMBER_LONG: l1 = *((const long *) ptr1); if (l1 != LONG_MIN) { if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, -l1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } TclSetLongObj(valuePtr, -l1); + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5921,6 +5945,7 @@ TEBCresume( */ valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { if (*pc == INST_UPLUS) { @@ -5928,7 +5953,7 @@ TEBCresume( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5937,7 +5962,7 @@ TEBCresume( } /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + TRACE_APPEND(("not numeric\n")); NEXT_INST_F(1, 0, 0); } if (IsErroringNaNType(type1)) { @@ -5946,7 +5971,7 @@ TEBCresume( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5956,8 +5981,7 @@ TEBCresume( * Numeric conversion of NaN -> error. */ - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(objResultPtr))); + TRACE_APPEND(("ERROR: IEEE floating pt error\n")); DECACHE_STACK_INFO(); TclExprFloatError(interp, *((const double *) ptr1)); CACHE_STACK_INFO(); @@ -5975,7 +5999,7 @@ TEBCresume( */ if (valuePtr->bytes == NULL) { - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } if (Tcl_IsShared(valuePtr)) { @@ -5990,11 +6014,11 @@ TEBCresume( valuePtr->bytes = NULL; objResultPtr = Tcl_DuplicateObj(valuePtr); valuePtr->bytes = savedString; - TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, new Tcl_Obj\n")); NEXT_INST_F(1, 1, 1); } TclInvalidateStringRep(valuePtr); - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } @@ -6011,6 +6035,7 @@ TEBCresume( */ result = TCL_BREAK; cleanup = 0; + TRACE(("=> BREAK!\n")); goto processExceptionReturn; case INST_CONTINUE: @@ -6021,6 +6046,7 @@ TEBCresume( */ result = TCL_CONTINUE; cleanup = 0; + TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; { @@ -6204,6 +6230,7 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc+1); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; + TRACE(("%u => ", opnd)); /* * Compute the number of iterations that will be run: iterMax @@ -6216,8 +6243,8 @@ TEBCresume( numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))); goto gotError; } if (Tcl_IsShared(listPtr)) { @@ -6253,6 +6280,7 @@ TEBCresume( TclNewObj(tmpPtr); tmpPtr->internalRep.otherValuePtr = infoPtr; PUSH_OBJECT(tmpPtr); /* infoPtr object */ + TRACE_APPEND(("jump to loop step\n")); /* * Jump directly to the INST_FOREACH_STEP instruction; the C code just @@ -6270,6 +6298,7 @@ TEBCresume( tmpPtr = OBJ_AT_TOS; infoPtr = tmpPtr->internalRep.otherValuePtr; numLists = infoPtr->numLists; + TRACE(("=> ")); tmpPtr = OBJ_AT_DEPTH(1); iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1); @@ -6323,9 +6352,8 @@ TEBCresume( if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR init. index temp %d: %.30s", + varIndex, O2S(Tcl_GetObjResult(interp)))); goto gotError; } CACHE_STACK_INFO(); @@ -6334,10 +6362,12 @@ TEBCresume( } listTmpDepth--; } + TRACE_APPEND(("jump to loop start\n")); /* loopCtTemp being 'misused' for storing the jump size */ NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); } + TRACE_APPEND(("loop has no more iterations\n")); #ifdef TCL_COMPILE_DEBUG NEXT_INST_F(1, 0, 0); #else @@ -6352,6 +6382,7 @@ TEBCresume( tmpPtr = OBJ_AT_TOS; infoPtr = tmpPtr->internalRep.otherValuePtr; numLists = infoPtr->numLists; + TRACE(("=> loop terminated\n")); NEXT_INST_V(1, numLists+2, 0); case INST_LMAP_COLLECT: @@ -6368,6 +6399,7 @@ TEBCresume( tmpPtr = OBJ_AT_DEPTH(1); infoPtr = tmpPtr->internalRep.otherValuePtr; numLists = infoPtr->numLists; + TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists)); objPtr = OBJ_AT_DEPTH(3 + numLists); Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); @@ -6433,7 +6465,8 @@ TEBCresume( if (code < TCL_ERROR || code > TCL_CONTINUE) { code = TCL_CONTINUE + 1; } - NEXT_INST_F(2*code -1, 1, 0); + TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1)); + NEXT_INST_F(2*code-1, 1, 0); } /* @@ -6450,10 +6483,10 @@ TEBCresume( case INST_DICT_VERIFY: dictPtr = OBJ_AT_TOS; - TRACE(("=> ")); + TRACE(("\"%.30s\" => ", O2S(dictPtr))); if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { - TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n", - O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp)))); + TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } TRACE_APPEND(("OK\n")); @@ -6479,7 +6512,7 @@ TEBCresume( goto afterDictExists; } TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%s\": ", + "ERROR tracing dictionary path into \"%.30s\": ", O2S(OBJ_AT_DEPTH(opnd))), Tcl_GetObjResult(interp)); goto gotError; @@ -6492,10 +6525,10 @@ TEBCresume( goto afterDictExists; } if (!objResultPtr) { - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "key \"%s\" not known in dictionary", TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(OBJ_AT_TOS), NULL); CACHE_STACK_INFO(); @@ -6595,8 +6628,8 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } - TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", - opnd, opnd2), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR updating dictionary: %s\n", + O2S(Tcl_GetObjResult(interp)))); goto checkForCatch; } @@ -6959,7 +6992,7 @@ TEBCresume( case INST_DICT_EXPAND: dictPtr = OBJ_UNDER_TOS; listPtr = OBJ_AT_TOS; - TRACE(("%.30s %.30s =>", O2S(dictPtr), O2S(listPtr))); + TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -6969,7 +7002,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); case INST_DICT_RECOMBINE_STK: @@ -7117,10 +7150,10 @@ TEBCresume( if (traceInstructions) { objPtr = Tcl_GetObjResult(interp); if ((result != TCL_ERROR) && (result != TCL_RETURN)) { - TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", + TRACE_APPEND(("OTHER RETURN CODE %d, result=\"%.30s\"\n ", result, O2S(objPtr))); } else { - TRACE_APPEND(("%s, result= \"%s\"\n", + TRACE_APPEND(("%s, result=\"%.30s\"\n", StringForResultCode(result), O2S(objPtr))); } } @@ -7133,8 +7166,8 @@ TEBCresume( */ divideByZero: - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); CACHE_STACK_INFO(); goto gotError; @@ -7145,9 +7178,9 @@ TEBCresume( */ exponOfZero: - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponentiation of zero by negative power", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); CACHE_STACK_INFO(); -- cgit v0.12 From c28c2d5b9aa31a0d76d65e0504118abcc75a835c Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 2 Jan 2014 08:35:01 +0000 Subject: oops... --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 37588c5..94ddab1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6244,7 +6244,7 @@ TEBCresume( listPtr = OBJ_AT_DEPTH(listTmpDepth); if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", - i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))); + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } if (Tcl_IsShared(listPtr)) { -- cgit v0.12 From 8a115927afc56356eb7398292b0fe7e00c766d02 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 2 Jan 2014 08:50:08 +0000 Subject: ... and more silly errors --- generic/tclExecute.c | 8 ++++---- unix/Makefile.in | 1 + 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 94ddab1..37a7397 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2788,7 +2788,7 @@ TEBCresume( objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); - TRACE(("=> mark depth as %d\n", CURR_DEPTH)); + TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH)); NEXT_INST_F(1, 0, 0); case INST_EXPAND_DROP: @@ -5041,7 +5041,7 @@ TEBCresume( } TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), - (match < 0 ? -1 : match > 0 : 1 : 0))); + (match < 0 ? -1 : match > 0 ? 1 : 0))); JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: @@ -6195,8 +6195,8 @@ TEBCresume( listTmpIndex++; } } - TRACE_APPEND(("%d lists, iter %d, %s loop\n", opnd, numLists, - iterNum, (continueLoop? "continue" : "exit"))); + TRACE_APPEND(("%d lists, iter %d, %s loop\n", + numLists, iterNum, (continueLoop? "continue" : "exit"))); /* * Run-time peep-hole optimisation: the compiler ALWAYS follows diff --git a/unix/Makefile.in b/unix/Makefile.in index a0d0c87..f74d516 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1195,6 +1195,7 @@ tclLoadDld.o: $(UNIX_DIR)/tclLoadDld.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDld.c tclLoadDyld.o: $(UNIX_DIR)/tclLoadDyld.c + @echo Warnings are expected from compiling tclLoadDyld.c: deprecated API use $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDyld.c tclLoadNone.o: $(GENERIC_DIR)/tclLoadNone.c -- cgit v0.12 From 430c9bc178a61061a4e2a4bdc1552f31f936f306 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 2 Jan 2014 15:30:53 +0000 Subject: redevelop code to have more in common with the interpreted [string is] and to remove non-working types --- generic/tclCompCmdsSZ.c | 147 +++++++++++++++++++++++++----------------------- 1 file changed, 78 insertions(+), 69 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 440b5bf..06cca50 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -435,56 +435,59 @@ TclCompileStringIsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int numWords = parsePtr->numWords; - enum IsType { - TypeBool, TypeBoolFalse, TypeBoolTrue, - TypeFloat, - TypeInteger, TypeNarrowInt, TypeWideInt, - TypeList /*, TypeDict */ + static const char *const isClasses[] = { + "alnum", "alpha", "ascii", "control", + "boolean", "digit", "double", "entier", + "false", "graph", "integer", "list", + "lower", "print", "punct", "space", + "true", "upper", "wideinteger", "wordchar", + "xdigit", NULL + }; + enum isClasses { + STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, + STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, + STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, + STR_IS_XDIGIT }; - enum IsType t; JumpFixup jumpFixup; - int start, range; - int allowEmpty = 0; + int t, range, allowEmpty = 0; + Tcl_Obj *isClass; - if (numWords < 2 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { return TCL_ERROR; } -#define GotLiteral(tokenPtr,word) \ - ((tokenPtr)[1].size > 1 && (tokenPtr)[1].start[0] == word[0] && \ - strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) - - if (GotLiteral(tokenPtr, "boolean")) { - t = TypeBool; - } else if (GotLiteral(tokenPtr, "double")) { - t = TypeFloat; - } else if (GotLiteral(tokenPtr, "entier")) { - t = TypeInteger; - } else if (GotLiteral(tokenPtr, "false")) { - t = TypeBoolFalse; - } else if (GotLiteral(tokenPtr, "integer")) { - t = TypeNarrowInt; - return TCL_ERROR; // Not yet implemented - } else if (GotLiteral(tokenPtr, "list")) { - t = TypeList; - } else if (GotLiteral(tokenPtr, "true")) { - t = TypeBoolTrue; - } else if (GotLiteral(tokenPtr, "wideinteger")) { - t = TypeWideInt; - return TCL_ERROR; // Not yet implemented - } else { - /* - * We don't handle character class checks in bytecode currently. - */ - + isClass = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) { + Tcl_DecrRefCount(isClass); return TCL_ERROR; + } else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0, + &t) != TCL_OK) { + Tcl_DecrRefCount(isClass); + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; } - if (numWords != 3 && numWords != 4) { + Tcl_DecrRefCount(isClass); + +#define GotLiteral(tokenPtr, word) \ + ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD && \ + (tokenPtr)[1].size > 1 && \ + (tokenPtr)[1].start[0] == word[0] && \ + strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) + + /* + * Cannot handle the -failindex option at all, and that's the only legal + * way to have more than 4 arguments. + */ + + if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { return TCL_ERROR; } + tokenPtr = TokenAfter(tokenPtr); - if (numWords == 3) { - allowEmpty = (t != TypeList); + if (parsePtr->numWords == 3) { + allowEmpty = (t != STR_IS_LIST); } else { if (!GotLiteral(tokenPtr, "-strict")) { return TCL_ERROR; @@ -494,18 +497,47 @@ TclCompileStringIsCmd( #undef GotLiteral /* + * Some types are not currently handled. Character classes are a prime + * example of this. + */ + + switch (t) { + case STR_IS_ALNUM: + case STR_IS_ALPHA: + case STR_IS_ASCII: + case STR_IS_CONTROL: + case STR_IS_DIGIT: + case STR_IS_GRAPH: + case STR_IS_LOWER: + case STR_IS_PRINT: + case STR_IS_PUNCT: + case STR_IS_SPACE: + case STR_IS_UPPER: + case STR_IS_WORD: + case STR_IS_XDIGIT: + return TCL_ERROR; + + case STR_IS_BOOL: + case STR_IS_FALSE: + case STR_IS_INT: + case STR_IS_TRUE: + case STR_IS_WIDE: + /* Not yet implemented */ + return TCL_ERROR; + } + + /* * Push the word to check. */ - CompileWord(envPtr, tokenPtr, interp, numWords-1); + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); /* * Next, do the type check. First, we push a catch range; most of the * type-check operations throw an exception on failure. */ - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - start = 0; + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -514,22 +546,7 @@ TclCompileStringIsCmd( */ switch (t) { - case TypeBool: - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LNOT, envPtr); - TclEmitOpcode( INST_POP, envPtr); - break; - case TypeBoolFalse: - TclEmitOpcode( INST_DUP, envPtr); - start = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); - break; - case TypeBoolTrue: - TclEmitOpcode( INST_DUP, envPtr); - start = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - break; - case TypeFloat: + case STR_IS_DOUBLE: /* * Careful! Preserve behavior of NaN which is a double (that is, true * for the purposes of a type check) but most math ops fail on it. The @@ -550,16 +567,12 @@ TclCompileStringIsCmd( TclEmitOpcode( INST_UMINUS, envPtr); TclEmitOpcode( INST_POP, envPtr); break; - case TypeInteger: + case STR_IS_ENTIER: TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_BITNOT, envPtr); TclEmitOpcode( INST_POP, envPtr); break; - case TypeNarrowInt: - Tcl_Panic("not yet implemented"); - case TypeWideInt: - Tcl_Panic("not yet implemented"); - case TypeList: + case STR_IS_LIST: TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); TclEmitOpcode( INST_POP, envPtr); @@ -579,10 +592,6 @@ TclCompileStringIsCmd( PushLiteral(envPtr, "1", 1); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); ExceptionRangeTarget(envPtr, range, catchOffset); - if (start != 0) { - TclStoreInt1AtPtr(CurrentOffset(envPtr) - start, - envPtr->codeStart + start + 1); - } TclEmitOpcode( INST_END_CATCH, envPtr); if (allowEmpty) { PushLiteral(envPtr, "", 0); -- cgit v0.12 From ea8a9ba07180ac5225a923afade42f2055d3a4e6 Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 5 Jan 2014 12:01:04 +0000 Subject: reducing TEBCdata: pc and cleanup now passed in the NREcallback --- generic/tclExecute.c | 40 ++++++++++++++++------------------------ 1 file changed, 16 insertions(+), 24 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 37a7397..3601b22 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -174,28 +174,24 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { typedef struct TEBCdata { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ - const unsigned char *pc; /* These fields are used on return TO this */ - ptrdiff_t *catchTop; /* this level: they record the state when a */ - int cleanup; /* new codePtr was received for NR */ - Tcl_Obj *auxObjList; /* execution. */ - CmdFrame cmdFrame; + ptrdiff_t *catchTop; /* These fields are used on return TO this */ + Tcl_Obj *auxObjList; /* this level: they record the state when a */ + CmdFrame cmdFrame; /* new codePtr was received for NR */ + /* execution. */ void *stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as * necessary */ } TEBCdata; #define TEBC_YIELD() \ - do { \ - esPtr->tosPtr = tosPtr; \ - TD->pc = pc; \ - TD->cleanup = cleanup; \ - TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \ + do { \ + esPtr->tosPtr = tosPtr; \ + TclNRAddCallback(interp, TEBCresume, \ + TD, pc, INT2PTR(cleanup), NULL); \ } while (0) #define TEBC_DATA_DIG() \ do { \ - pc = TD->pc; \ - cleanup = TD->cleanup; \ tosPtr = esPtr->tosPtr; \ } while (0) @@ -2032,10 +2028,6 @@ TclNRExecuteByteCode( * sizeof(void *); int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - if (iPtr->execEnvPtr->rewind) { - return TCL_ERROR; - } - codePtr->refCount++; /* @@ -2054,9 +2046,7 @@ TclNRExecuteByteCode( esPtr->tosPtr = initTosPtr; TD->codePtr = codePtr; - TD->pc = codePtr->codeStart; TD->catchTop = initCatchTop; - TD->cleanup = 0; TD->auxObjList = NULL; /* @@ -2086,8 +2076,8 @@ TclNRExecuteByteCode( * Push the callback for bytecode execution */ - TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0), - NULL, NULL); + TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL, + /* cleanup */ INT2PTR(0), NULL); return TCL_OK; } @@ -2150,7 +2140,8 @@ TEBCresume( Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation * stack. */ - const unsigned char *pc; /* The current program counter. */ + const unsigned char *pc = data[1]; + /* The current program counter. */ unsigned char inst; /* The currently running instruction */ /* @@ -2158,7 +2149,7 @@ TEBCresume( * executing an instruction. */ - int cleanup = 0; + int cleanup = PTR2INT(data[2]); Tcl_Obj *objResultPtr; int checkInterp; /* Indicates when a check of interp readyness * is necessary. Set by CACHE_STACK_INFO() */ @@ -2186,16 +2177,17 @@ TEBCresume( TEBC_DATA_DIG(); #ifdef TCL_COMPILE_DEBUG - if (!data[1] && (tclTraceExec >= 2)) { + if (!pc && (tclTraceExec >= 2)) { PrintByteCodeInfo(codePtr); fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); fflush(stdout); } #endif - if (!data[1]) { + if (!pc) { /* bytecode is starting from scratch */ checkInterp = 0; + pc = codePtr->codeStart; goto cleanup0; } else { /* resume from invocation */ -- cgit v0.12 From bb9e19e6ebdd55ac3ff07550d312e931d389a863 Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 5 Jan 2014 14:10:42 +0000 Subject: skip the switch(result) on returning TCL_OK from a proc --- generic/tclProc.c | 72 +++++++++++++++++++++++++------------------------------ 1 file changed, 32 insertions(+), 40 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 1314719..ce1c767 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1855,9 +1855,39 @@ InterpProcNR2( } /* - * Process the result code. + * Free the stack-allocated compiled locals and CallFrame. It is important + * to pop the call frame without freeing it first: the compiledLocals + * cannot be freed before the frame is popped, as the local variables must + * be deleted. But the compiledLocals must be freed first, as they were + * allocated later on the stack. */ + if (result != TCL_OK) { + goto process; + } + + done: + if (TCL_DTRACE_PROC_RESULT_ENABLED()) { + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Obj *r = Tcl_GetObjResult(interp); + + TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? + TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result, + TclGetString(r), r); + } + + freePtr = iPtr->framePtr; + Tcl_PopCallFrame(interp); /* Pop but do not free. */ + TclStackFree(interp, freePtr->compiledLocals); + /* Free compiledLocals. */ + TclStackFree(interp, freePtr); /* Free CallFrame. */ + return result; + + /* + * Process any non-TCL_OK result code. + */ + + process: switch (result) { case TCL_RETURN: /* @@ -1892,46 +1922,8 @@ InterpProcNR2( */ errorProc(interp, procNameObj); - - default: - /* - * Process other results (OK and non-standard) by doing nothing - * special, skipping directly to the code afterwards that cleans up - * associated memory. - * - * Non-standard results are processed by passing them through quickly. - * This means they all work as exceptions, unwinding the stack quickly - * and neatly. Who knows how well they are handled by third-party code - * though... - */ - - (void) 0; /* do nothing */ - } - - if (TCL_DTRACE_PROC_RESULT_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - Tcl_Obj *r = Tcl_GetObjResult(interp); - - TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result, - TclGetString(r), r); } - - /* - * Free the stack-allocated compiled locals and CallFrame. It is important - * to pop the call frame without freeing it first: the compiledLocals - * cannot be freed before the frame is popped, as the local variables must - * be deleted. But the compiledLocals must be freed first, as they were - * allocated later on the stack. - */ - - freePtr = iPtr->framePtr; - Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); - /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ - - return result; + goto done; } /* -- cgit v0.12 From 666deab1ead0be92519de1b323a89652217b68ea Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 5 Jan 2014 15:01:52 +0000 Subject: fix arraySet compiler to set -errorcode instead of -errorCode in return options --- generic/tclCompCmds.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 323aa87..3d5bfe0 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -278,7 +278,7 @@ TclCompileArraySetCmd( if (isDataValid && !isDataEven) { PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); + PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); goto done; @@ -373,7 +373,7 @@ TclCompileArraySetCmd( offsetFwd = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); + PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); TclAdjustStackDepth(-1, envPtr); -- cgit v0.12 From 6bb7b1e15d075adf898359785bd2838982343c84 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 5 Jan 2014 17:31:38 +0000 Subject: factor out a common stanza --- generic/tclExecute.c | 61 ++++++++++++++++++++++++++++++++++------------------ 1 file changed, 40 insertions(+), 21 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f25b588..612a5cb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1996,6 +1996,41 @@ TclIncrObj( /* *---------------------------------------------------------------------- * + * ArgumentBCEnter -- + * + * This is a helper for TclNRExecuteByteCode/TEBCresume that encapsulates + * a code sequence that is fairly common in the code but *not* commonly + * called. + * + * Results: + * None + * + * Side effects: + * May register information about the bytecode in the command frame. + * + *---------------------------------------------------------------------- + */ + +static void +ArgumentBCEnter( + Tcl_Interp *interp, + ByteCode *codePtr, + TEBCdata *tdPtr, + const unsigned char *pc, + int objc, + Tcl_Obj **objv) +{ + int cmd; + + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd, + pc - codePtr->codeStart); + } +} + +/* + *---------------------------------------------------------------------- + * * TclNRExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It @@ -2205,7 +2240,7 @@ TEBCresume( } iPtr->cmdFramePtr = bcFramePtr->nextPtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + TclArgumentBCRelease(interp, bcFramePtr); } if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { iPtr->flags |= ERR_ALREADY_LOGGED; @@ -2487,11 +2522,7 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } pc++; @@ -2961,11 +2992,7 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } DECACHE_STACK_INFO(); @@ -3110,11 +3137,7 @@ TEBCresume( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = opnd; @@ -4559,11 +4582,7 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } pcAdjustment = 2; -- cgit v0.12 From 03ecb591a69e41a6c3f69fc8477b3f186e7745cf Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 7 Jan 2014 13:59:30 +0000 Subject: reduce the overhead of NR-enabled TclOO [next] --- generic/tclExecute.c | 136 +++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 127 insertions(+), 9 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 612a5cb..5b42124 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -800,7 +800,8 @@ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; - +static Tcl_NRPostProc FinalizeOONext; +static Tcl_NRPostProc FinalizeOONextFilter; static Tcl_NRPostProc TEBCresume; /* @@ -4535,6 +4536,7 @@ TEBCresume( */ { + Object *oPtr; CallFrame *framePtr; CallContext *contextPtr; @@ -4578,6 +4580,53 @@ TEBCresume( } contextPtr = framePtr->clientData; + if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + /* + * We're at the end of the chain; generate an error message unless + * the interpreter is being torn down, in which case we might be + * getting here because of methods/destructors doing a [next] (or + * equivalent) unexpectedly. + */ + + const char *methodType; + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + TRACE_APPEND(("ERROR: no TclOO next impl\n")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + int i; + + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("next_in_chain ")); + } else { + fprintf(stdout, "%d: (%u) invoking next_in_chain ", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); + } + for (i = 0; i < objc; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; @@ -4591,14 +4640,31 @@ TEBCresume( iPtr->varFramePtr = framePtr->callerVarPtr; pc += pcAdjustment; TEBC_YIELD(); - TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, - NULL, NULL, NULL); - /* TODO: consider merging another layer of processing */ - return TclNRObjectContextInvokeNext(interp, - (Tcl_ObjectContext) contextPtr, opnd, &OBJ_AT_DEPTH(opnd-1), 1); - } - { - Object *oPtr; + oPtr = contextPtr->oPtr; + if (oPtr->flags & FILTER_HANDLING) { + TclNRAddCallback(interp, FinalizeOONextFilter, + framePtr, contextPtr, INT2PTR(contextPtr->index), + INT2PTR(contextPtr->skip)); + } else { + TclNRAddCallback(interp, FinalizeOONext, + framePtr, contextPtr, INT2PTR(contextPtr->index), + INT2PTR(contextPtr->skip)); + } + if (contextPtr->callPtr->chain[++contextPtr->index].isFilter + || contextPtr->callPtr->flags & FILTER_HANDLING) { + oPtr->flags |= FILTER_HANDLING; + } else { + oPtr->flags &= ~FILTER_HANDLING; + } + contextPtr->skip = 1; + { + register Method *const mPtr = + contextPtr->callPtr->chain[contextPtr->index].mPtr; + + return mPtr->typePtr->callProc(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, opnd, + &OBJ_AT_DEPTH(opnd-1)); + } case INST_TCLOO_IS_OBJECT: oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); @@ -7766,6 +7832,58 @@ TEBCresume( #undef auxObjList #undef catchTop #undef TCONST + +static int +FinalizeOONext( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; + + /* + * Reset the variable lookup frame. + */ + + iPtr->varFramePtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[2]); + contextPtr->skip = PTR2INT(data[3]); + contextPtr->oPtr->flags &= ~FILTER_HANDLING; + return result; +} + +static int +FinalizeOONextFilter( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; + + /* + * Reset the variable lookup frame. + */ + + iPtr->varFramePtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[2]); + contextPtr->skip = PTR2INT(data[3]); + contextPtr->oPtr->flags |= FILTER_HANDLING; + return result; +} /* *---------------------------------------------------------------------- -- cgit v0.12 From cbc312324ed9599429daa96fe21ca833fe3c969c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 7 Jan 2014 14:13:37 +0000 Subject: make function static once more; not needed outside of source file --- generic/tclInt.h | 1 - generic/tclOOBasic.c | 21 +++++++++------------ 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index f10beae..3aaa30b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2734,7 +2734,6 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; -MODULE_SCOPE Tcl_NRPostProc TclOONextRestoreFrame; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 49c917b..6084cf2 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -17,14 +17,11 @@ #include "tclOOInt.h" static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp); -static int AfterNRDestructor(ClientData data[], - Tcl_Interp *interp, int result); -static int DecrRefsPostClassConstructor(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeConstruction(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeEval(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc AfterNRDestructor; +static Tcl_NRPostProc DecrRefsPostClassConstructor; +static Tcl_NRPostProc FinalizeConstruction; +static Tcl_NRPostProc FinalizeEval; +static Tcl_NRPostProc NextRestoreFrame; /* * ---------------------------------------------------------------------- @@ -806,7 +803,7 @@ TclOONextObjCmd( * that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, NULL,NULL,NULL); + TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL); iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } @@ -875,7 +872,7 @@ TclOONextToObjCmd( * context. Note that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, + TclNRAddCallback(interp, NextRestoreFrame, framePtr, contextPtr, INT2PTR(contextPtr->index), NULL); contextPtr->index = i-1; iPtr->varFramePtr = framePtr->callerVarPtr; @@ -905,8 +902,8 @@ TclOONextToObjCmd( return TCL_ERROR; } -int -TclOONextRestoreFrame( +static int +NextRestoreFrame( ClientData data[], Tcl_Interp *interp, int result) -- cgit v0.12 From 48459b2357f3a18ad09428bfaaf5de5ef3d50292 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Jan 2014 11:04:44 +0000 Subject: Make DEFAULT_TRIM_SET a MODULE_SCOPE string constant, so its value can be shared in tclCmdMZ.o and TclCompCmdsSZ.o and it no longer pollutes the tclStringTrim.h header file. --- generic/tclCmdMZ.c | 45 +++++++++++++++++++++++++++++++++++++++------ generic/tclCompCmdsSZ.c | 6 +++--- generic/tclStringTrim.h | 27 +-------------------------- 3 files changed, 43 insertions(+), 35 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d477216..c02cd1a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -32,6 +32,39 @@ static int TryPostHandler(ClientData data[], Tcl_Interp *interp, int result); static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); + +/* + * Default set of characters to trim in [string trim] and friends. This is a + * UTF-8 literal string containing all Unicode space characters [TIP #413] + */ + +const char tclDefaultTrimSet[] = + "\x09\x0a\x0b\x0c\x0d " /* ASCII */ + "\xc0\x80" /* nul (U+0000) */ + "\xc2\x85" /* next line (U+0085) */ + "\xc2\xa0" /* non-breaking space (U+00a0) */ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */ + "\xe2\x80\x80" /* en quad (U+2000) */ + "\xe2\x80\x81" /* em quad (U+2001) */ + "\xe2\x80\x82" /* en space (U+2002) */ + "\xe2\x80\x83" /* em space (U+2003) */ + "\xe2\x80\x84" /* three-per-em space (U+2004) */ + "\xe2\x80\x85" /* four-per-em space (U+2005) */ + "\xe2\x80\x86" /* six-per-em space (U+2006) */ + "\xe2\x80\x87" /* figure space (U+2007) */ + "\xe2\x80\x88" /* punctuation space (U+2008) */ + "\xe2\x80\x89" /* thin space (U+2009) */ + "\xe2\x80\x8a" /* hair space (U+200a) */ + "\xe2\x80\x8b" /* zero width space (U+200b) */ + "\xe2\x80\xa8" /* line separator (U+2028) */ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */ + "\xe2\x81\xa0" /* word joiner (U+2060) */ + "\xe3\x80\x80" /* ideographic space (U+3000) */ + "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ +; /* *---------------------------------------------------------------------- @@ -3158,8 +3191,8 @@ StringTrimCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3206,8 +3239,8 @@ StringTrimLCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3252,8 +3285,8 @@ StringTrimRCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0f2790f..c54a06a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -810,7 +810,7 @@ TclCompileStringTrimLCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { - PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } OP( STR_TRIM_LEFT); return TCL_OK; @@ -838,7 +838,7 @@ TclCompileStringTrimRCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { - PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } OP( STR_TRIM_RIGHT); return TCL_OK; @@ -866,7 +866,7 @@ TclCompileStringTrimCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { - PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } OP( STR_TRIM); return TCL_OK; diff --git a/generic/tclStringTrim.h b/generic/tclStringTrim.h index 669f10b..030e4ec 100644 --- a/generic/tclStringTrim.h +++ b/generic/tclStringTrim.h @@ -23,32 +23,7 @@ * UTF-8 literal string containing all Unicode space characters. [TIP #413] */ -#define DEFAULT_TRIM_SET \ - "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ - "\xc0\x80" /* nul (U+0000) */\ - "\xc2\x85" /* next line (U+0085) */\ - "\xc2\xa0" /* non-breaking space (U+00a0) */\ - "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ - "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ - "\xe2\x80\x80" /* en quad (U+2000) */\ - "\xe2\x80\x81" /* em quad (U+2001) */\ - "\xe2\x80\x82" /* en space (U+2002) */\ - "\xe2\x80\x83" /* em space (U+2003) */\ - "\xe2\x80\x84" /* three-per-em space (U+2004) */\ - "\xe2\x80\x85" /* four-per-em space (U+2005) */\ - "\xe2\x80\x86" /* six-per-em space (U+2006) */\ - "\xe2\x80\x87" /* figure space (U+2007) */\ - "\xe2\x80\x88" /* punctuation space (U+2008) */\ - "\xe2\x80\x89" /* thin space (U+2009) */\ - "\xe2\x80\x8a" /* hair space (U+200a) */\ - "\xe2\x80\x8b" /* zero width space (U+200b) */\ - "\xe2\x80\xa8" /* line separator (U+2028) */\ - "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ - "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ - "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ - "\xe2\x81\xa0" /* word joiner (U+2060) */\ - "\xe3\x80\x80" /* ideographic space (U+3000) */\ - "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ +MODULE_SCOPE const char tclDefaultTrimSet[]; /* * The whitespace trimming set used when [concat]enating. This is a subset of -- cgit v0.12 From 29ae06c2d37c62b89dbc679c87cffd292b077cbf Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 9 Jan 2014 10:49:04 +0000 Subject: use compact form --- generic/tclCompCmdsSZ.c | 51 ++++++++++++++++++++++++------------------------- 1 file changed, 25 insertions(+), 26 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 06cca50..345dd9f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -451,8 +451,7 @@ TclCompileStringIsCmd( STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT }; - JumpFixup jumpFixup; - int t, range, allowEmpty = 0; + int t, range, allowEmpty = 0, end; Tcl_Obj *isClass; if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { @@ -538,7 +537,7 @@ TclCompileStringIsCmd( */ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); /* @@ -554,28 +553,28 @@ TclCompileStringIsCmd( * this is true for). */ - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_NEQ, envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 5, envPtr); + OP( DUP); + OP( DUP); + OP( NEQ); + OP1( JUMP_TRUE1, 5); /* * Type check for all other double values. */ - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_UMINUS, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( DUP); + OP( UMINUS); + OP( POP); break; case STR_IS_ENTIER: - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_BITNOT, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( DUP); + OP( BITNOT); + OP( POP); break; case STR_IS_LIST: - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( DUP); + OP( LIST_LENGTH); + OP( POP); break; } @@ -587,20 +586,20 @@ TclCompileStringIsCmd( */ ExceptionRangeEnds(envPtr, range); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "1", 1); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + OP( END_CATCH); + OP( POP); + PUSH( "1"); + JUMP1( JUMP, end); ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_END_CATCH, envPtr); + OP( END_CATCH); if (allowEmpty) { - PushLiteral(envPtr, "", 0); - TclEmitOpcode( INST_STR_EQ, envPtr); + PUSH( ""); + OP( STR_EQ); } else { - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "0", 1); + OP( POP); + PUSH( "0"); } - TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + FIXJUMP1( end); return TCL_OK; } -- cgit v0.12 From 2803a8a05559eeba811d825d94efcb3acc1c9eb5 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 10 Jan 2014 15:58:41 +0000 Subject: a different approach --- generic/tclAssembly.c | 4 +- generic/tclCompCmdsSZ.c | 150 ++++++++++++++++++++++++++---------------------- generic/tclCompile.c | 4 ++ generic/tclCompile.h | 4 +- generic/tclExecute.c | 8 +++ 5 files changed, 98 insertions(+), 72 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 89c286a..70379c6 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -437,6 +437,7 @@ static const TalInstDesc TalInstructionTable[] = { {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, + {"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1}, {"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1}, {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, @@ -516,7 +517,8 @@ static const unsigned char NonThrowingByteCodes[] = { INST_RESOLVE_COMMAND, /* 154 */ INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ INST_CONCAT_STK, /* 169 */ - INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE /* 170-172 */ + INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */ + INST_NUM_TYPE /* 180 */ }; /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 345dd9f..1436a20 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -500,7 +500,7 @@ TclCompileStringIsCmd( * example of this. */ - switch (t) { + switch ((enum isClasses) t) { case STR_IS_ALNUM: case STR_IS_ALPHA: case STR_IS_ASCII: @@ -514,93 +514,103 @@ TclCompileStringIsCmd( case STR_IS_UPPER: case STR_IS_WORD: case STR_IS_XDIGIT: + /* Not yet implemented */ return TCL_ERROR; case STR_IS_BOOL: case STR_IS_FALSE: - case STR_IS_INT: case STR_IS_TRUE: - case STR_IS_WIDE: /* Not yet implemented */ return TCL_ERROR; - } - - /* - * Push the word to check. - */ - - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); - /* - * Next, do the type check. First, we push a catch range; most of the - * type-check operations throw an exception on failure. - */ - - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - - /* - * Issue the type-check itself for the specific type. - */ + case STR_IS_DOUBLE: { + int satisfied, isEmpty; - switch (t) { - case STR_IS_DOUBLE: - /* - * Careful! Preserve behavior of NaN which is a double (that is, true - * for the purposes of a type check) but most math ops fail on it. The - * key is that it is not == to itself (and is the only value which - * this is true for). - */ + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + if (allowEmpty) { + OP( DUP); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP_TRUE, isEmpty); + OP( NUM_TYPE); + JUMP1( JUMP_TRUE, satisfied); + PUSH( "0"); + JUMP1( JUMP, end); + FIXJUMP1( isEmpty); + OP( POP); + FIXJUMP1( satisfied); + } else { + OP( NUM_TYPE); + JUMP1( JUMP_TRUE, satisfied); + PUSH( "0"); + JUMP1( JUMP, end); + TclAdjustStackDepth(-1, envPtr); + FIXJUMP1( satisfied); + } + PUSH( "1"); + FIXJUMP1( end); + return TCL_OK; + } - OP( DUP); - OP( DUP); - OP( NEQ); - OP1( JUMP_TRUE1, 5); + case STR_IS_INT: + case STR_IS_WIDE: + case STR_IS_ENTIER: + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + if (allowEmpty) { + int testNumType; + + OP( DUP); + OP( NUM_TYPE); + OP( DUP); + JUMP1( JUMP_TRUE, testNumType); + OP( POP); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP, end); + TclAdjustStackDepth(1, envPtr); + FIXJUMP1( testNumType); + OP4( REVERSE, 2); + OP( POP); + } else { + OP( NUM_TYPE); + OP( DUP); + JUMP1( JUMP_FALSE, end); + } - /* - * Type check for all other double values. - */ + switch (t) { + case STR_IS_INT: + PUSH( "1"); + OP( EQ); + break; + case STR_IS_WIDE: + PUSH( "2"); + OP( LE); + break; + case STR_IS_ENTIER: + PUSH( "3"); + OP( LE); + break; + } + FIXJUMP1( end); + return TCL_OK; - OP( DUP); - OP( UMINUS); - OP( POP); - break; - case STR_IS_ENTIER: - OP( DUP); - OP( BITNOT); - OP( POP); - break; case STR_IS_LIST: + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); OP( DUP); OP( LIST_LENGTH); OP( POP); - break; - } - - /* - * Based on whether the exception was thrown (or conditional branch taken, - * in the case of true/false checks), push the correct boolean value. This - * is also where we deal with what happens with empty values in non-strict - * mode. - */ - - ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); - OP( POP); - PUSH( "1"); - JUMP1( JUMP, end); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( END_CATCH); - if (allowEmpty) { - PUSH( ""); - OP( STR_EQ); - } else { + ExceptionRangeEnds(envPtr, range); + ExceptionRangeTarget(envPtr, range, catchOffset); OP( POP); - PUSH( "0"); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( LNOT); + return TCL_OK; } - FIXJUMP1( end); - return TCL_OK; + return TCL_ERROR; } int diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ee67e24..c01571f 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -621,6 +621,10 @@ InstructionDesc const tclInstructionTable[] = { /* Push the identity of the current TclOO object (i.e., the name of * its current public access command) on the stack. */ + {"numericType", 1, 0, 0, {OPERAND_NONE}}, + /* Pushes the numeric type code of the word at the top of the stack. + * Stack: ... value => ... typeCode */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6ecadf4..6bf5daf 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -792,8 +792,10 @@ typedef struct ByteCode { #define INST_TCLOO_NEXT 179 +#define INST_NUM_TYPE 180 + /* The last opcode */ -#define LAST_INST_OPCODE 179 +#define LAST_INST_OPCODE 180 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5b42124..2707ec1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5776,6 +5776,14 @@ TEBCresume( int type1, type2; long l1, l2, lResult; + case INST_NUM_TYPE: + if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { + type1 = 0; + } + TclNewIntObj(objResultPtr, type1); + TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); + NEXT_INST_F(1, 1, 1); + case INST_EQ: case INST_NEQ: case INST_LT: -- cgit v0.12 From 12945e9a1687504978a49e6a8739ea3f1b20b02e Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 13 Jan 2014 08:06:43 +0000 Subject: extend [string is] to booleans --- generic/tclAssembly.c | 1 + generic/tclCompCmdsSZ.c | 51 +++++++++++++++++++++++++++++++++++++++++++++---- generic/tclCompile.c | 3 +++ generic/tclCompile.h | 3 ++- generic/tclExecute.c | 11 +++++++++++ 5 files changed, 64 insertions(+), 5 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 70379c6..f10bca8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -478,6 +478,7 @@ static const TalInstDesc TalInstructionTable[] = { {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, + {"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2}, {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 1436a20..91bb94c 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -514,14 +514,57 @@ TclCompileStringIsCmd( case STR_IS_UPPER: case STR_IS_WORD: case STR_IS_XDIGIT: - /* Not yet implemented */ - return TCL_ERROR; + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); case STR_IS_BOOL: case STR_IS_FALSE: case STR_IS_TRUE: - /* Not yet implemented */ - return TCL_ERROR; + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + OP( TRY_CVT_TO_BOOLEAN); + switch (t) { + int over, over2; + + case STR_IS_BOOL: + if (allowEmpty) { + JUMP1( JUMP_TRUE, over); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP, over2); + FIXJUMP1(over); + OP( POP); + PUSH( "1"); + FIXJUMP1(over2); + } else { + OP4( REVERSE, 2); + OP( POP); + } + return TCL_OK; + case STR_IS_TRUE: + JUMP1( JUMP_TRUE, over); + if (allowEmpty) { + PUSH( ""); + OP( STR_EQ); + } else { + OP( POP); + PUSH( "0"); + } + FIXJUMP1( over); + OP( LNOT); + OP( LNOT); + return TCL_OK; + case STR_IS_FALSE: + JUMP1( JUMP_TRUE, over); + if (allowEmpty) { + PUSH( ""); + OP( STR_NEQ); + } else { + OP( POP); + PUSH( "1"); + } + FIXJUMP1( over); + OP( LNOT); + return TCL_OK; + } case STR_IS_DOUBLE: { int satisfied, isEmpty; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c01571f..39fa241 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -624,6 +624,9 @@ InstructionDesc const tclInstructionTable[] = { {"numericType", 1, 0, 0, {OPERAND_NONE}}, /* Pushes the numeric type code of the word at the top of the stack. * Stack: ... value => ... typeCode */ + {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}}, + /* Try converting stktop to boolean if possible. No errors. + * Stack: ... value => ... value isStrictBool */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6bf5daf..a08a93a 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -793,9 +793,10 @@ typedef struct ByteCode { #define INST_TCLOO_NEXT 179 #define INST_NUM_TYPE 180 +#define INST_TRY_CVT_TO_BOOLEAN 181 /* The last opcode */ -#define LAST_INST_OPCODE 180 +#define LAST_INST_OPCODE 181 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2707ec1..989b7b6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6461,6 +6461,17 @@ TEBCresume( * ----------------------------------------------------------------- */ + case INST_TRY_CVT_TO_BOOLEAN: + valuePtr = OBJ_AT_TOS; + if (valuePtr->typePtr == &tclBooleanType) { + objResultPtr = TCONST(1); + } else { + int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); + objResultPtr = TCONST(result); + } + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); + NEXT_INST_F(1, 0, 1); + case INST_BREAK: /* DECACHE_STACK_INFO(); -- cgit v0.12 From a994cc42f5a2c2758e6f3da6fdba0a390f7d1538 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 15 Jan 2014 19:04:52 +0000 Subject: [2992970] Restore the safety of Tcl_AppendObjToObj(x, x) for bytearrays. Also moves overflow checking to TclAppendBytesToByteArray() and adds the ability to call TABTBA() with bytes==NULL, for appending unspecified bytes. That is, the string grows, but the new bytes are of undetermined value. Like Tcl_NewByteArrayObj(NULL, length) this option is useful for manipulating buffers. The TABTBA growth algorithm is also enhanced a bit, copying over a fuller implementation from GrowStringBuffer() in tclStringObj.c --- generic/tclBinary.c | 74 ++++++++++++++++++++++---------------------------- generic/tclStringObj.c | 42 ++++++++++++++++++++-------- 2 files changed, 64 insertions(+), 52 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 4e977f2..981f174 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -610,9 +610,7 @@ UpdateStringOfByteArray( * * This function appends an array of bytes to a byte array object. Note * that the object *must* be unshared, and the array of bytes *must not* - * refer to the object being appended to. Also the caller must have - * already checked that the final length of the bytearray after the - * append operations is complete will not overflow the int range. + * refer to the object being appended to. * * Results: * None. @@ -631,6 +629,7 @@ TclAppendBytesToByteArray( int len) { ByteArray *byteArrayPtr; + int needed; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -639,64 +638,57 @@ TclAppendBytesToByteArray( Tcl_Panic("%s must be called with definite number of bytes to append", "TclAppendBytesToByteArray"); } + if (len == 0) { + /* Append zero bytes is a no-op. */ + return; + } if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); } byteArrayPtr = GET_BYTEARRAY(objPtr); + if (len > INT_MAX - byteArrayPtr->used) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + needed = byteArrayPtr->used + len; /* * If we need to, resize the allocated space in the byte array. */ - if (byteArrayPtr->used + len > byteArrayPtr->allocated) { - unsigned int attempt, used = byteArrayPtr->used; - ByteArray *tmpByteArrayPtr = NULL; + if (needed > byteArrayPtr->allocated) { + ByteArray *ptr = NULL; + int attempt; - attempt = byteArrayPtr->allocated; - if (attempt < 1) { - /* - * No allocated bytes, so must be none used too. We use this - * method to calculate how many bytes to allocate because we can - * end up with a zero-length buffer otherwise, when doubling can - * cause trouble. [Bug 3067036] - */ - - attempt = len + 1; - } else { - do { - attempt *= 2; - } while (attempt < used+len); + if (needed <= INT_MAX/2) { + /* Try to allocate double the total space that is needed. */ + attempt = 2 * needed; + ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } + if (ptr == NULL) { + /* Try to allocate double the increment that is needed (plus). */ + unsigned int limit = INT_MAX - needed; + unsigned int extra = len + TCL_MIN_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); - if (BYTEARRAY_SIZE(attempt) > BYTEARRAY_SIZE(used)) { - tmpByteArrayPtr = attemptckrealloc(byteArrayPtr, - BYTEARRAY_SIZE(attempt)); + attempt = needed + growth; + ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } - - if (tmpByteArrayPtr == NULL) { - attempt = used + len; - if (BYTEARRAY_SIZE(attempt) < BYTEARRAY_SIZE(used)) { - Tcl_Panic("attempt to allocate a bigger buffer than we can handle"); - } - tmpByteArrayPtr = ckrealloc(byteArrayPtr, - BYTEARRAY_SIZE(attempt)); + if (ptr == NULL) { + /* Last chance: Try to allocate exactly what is needed. */ + attempt = needed; + ptr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } - - byteArrayPtr = tmpByteArrayPtr; + byteArrayPtr = ptr; byteArrayPtr->allocated = attempt; - byteArrayPtr->used = used; SET_BYTEARRAY(objPtr, byteArrayPtr); } - /* - * Do the append if there's any point. - */ - - if (len > 0) { + if (bytes) { memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); - byteArrayPtr->used += len; - TclInvalidateStringRep(objPtr); } + byteArrayPtr->used += len; + TclInvalidateStringRep(objPtr); } /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index e495c2e..1512f0c 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1281,23 +1281,43 @@ Tcl_AppendObjToObj( if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) && TclIsPureByteArray(appendObjPtr)) { - unsigned char *bytesSrc; - int lengthSrc, lengthTotal; + int lengthSrc; /* - * We do not assume that objPtr and appendObjPtr must be distinct! - * This makes this code a bit more complex than it otherwise would be, - * but in turn makes it much safer. + * You might expect the code here to be + * + + bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length); + TclAppendBytesToByteArray(objPtr, bytes, length); + + * + * and essentially all of the time that would be fine. However, + * it would run into trouble in the case where objPtr and + * appendObjPtr point to the same thing. That may never be a + * good idea. It seems to violate Copy On Write, and we don't + * have any tests for the situation, since making any Tcl commands + * that call Tcl_AppendObjToObj() do that appears impossible + * (They honor Copy On Write!). For the sake of extensions that + * go off into that realm, though, here's a more complex approach + * that can handle all the cases. */ + /* Get lengths */ (void) Tcl_GetByteArrayFromObj(objPtr, &length); (void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc); - lengthTotal = length + lengthSrc; - if (((length > lengthSrc) ? length : lengthSrc) > lengthTotal) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - bytesSrc = Tcl_GetByteArrayFromObj(appendObjPtr, NULL); - TclAppendBytesToByteArray(objPtr, bytesSrc, lengthSrc); + + /* Grow buffer enough for the append */ + TclAppendBytesToByteArray(objPtr, NULL, lengthSrc); + + /* Reset objPtr back to the original value */ + Tcl_SetByteArrayLength(objPtr, length); + + /* + * Now do the append secure that buffer growth cannot cause + * any trouble. + */ + TclAppendBytesToByteArray(objPtr, + Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc); return; } -- cgit v0.12 From 88b2f7f06e994621c0a8e374cdf70b85abd3a173 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 19 Jan 2014 18:39:24 +0000 Subject: added compilation for [nextto] --- generic/tclAssembly.c | 1 + generic/tclCompCmdsGR.c | 25 +++++++++ generic/tclCompile.c | 14 ++++- generic/tclCompile.h | 3 +- generic/tclExecute.c | 132 +++++++++++++++++++++++++++++++++++++++++++----- generic/tclInt.h | 3 ++ generic/tclOO.c | 3 +- generic/tclOOBasic.c | 20 ++++++-- 8 files changed, 179 insertions(+), 22 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 89c286a..7b775a9 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -26,6 +26,7 @@ *- jumpTable testing *- syntax (?) *- returnCodeBranch + *- tclooNext, tclooNextClass */ #include "tclInt.h" diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index b8a7e0f..b3e273f 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -3075,6 +3075,31 @@ TclCompileObjectNextCmd( } int +TclCompileObjectNextToCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + int i; + + if (parsePtr->numWords < 2 || parsePtr->numWords > 255) { + return TCL_ERROR; + } + + for (i=0 ; inumWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr); + return TCL_OK; +} + +int TclCompileObjectSelfCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ee67e24..bd97e3e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -618,8 +618,18 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... cmdName => ... fullOriginalCmdName */ {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Push the identity of the current TclOO object (i.e., the name of - * its current public access command) on the stack. */ + /* Call the next item on the TclOO call chain, passing opnd arguments + * (min 1, max 255, *includes* "next"). The result of the invoked + * method implementation will be pushed on the stack in place of the + * arguments (similar to invokeStk). + * Stack: ... "next" arg2 arg3 -- argN => ... result */ + {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call the following item on the TclOO call chain defined by class + * className, passing opnd arguments (min 2, max 255, *includes* + * "nextto" and the class name). The result of the invoked method + * implementation will be pushed on the stack in place of the + * arguments (similar to invokeStk). + * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6ecadf4..b047855 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -791,9 +791,10 @@ typedef struct ByteCode { #define INST_ORIGIN_COMMAND 178 #define INST_TCLOO_NEXT 179 +#define INST_TCLOO_NEXT_CLASS 180 /* The last opcode */ -#define LAST_INST_OPCODE 179 +#define LAST_INST_OPCODE 180 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5b42124..ac0ea12 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4539,6 +4539,7 @@ TEBCresume( Object *oPtr; CallFrame *framePtr; CallContext *contextPtr; + int skip, newDepth; case INST_TCLOO_SELF: framePtr = iPtr->varFramePtr; @@ -4563,9 +4564,111 @@ TEBCresume( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + case INST_TCLOO_NEXT_CLASS: + opnd = TclGetUInt1AtPtr(pc+1); + framePtr = iPtr->varFramePtr; + valuePtr = OBJ_AT_DEPTH(opnd - 2); + objv = &OBJ_AT_DEPTH(opnd - 1); + skip = 2; + TRACE(("%d => ", opnd)); + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE_APPEND(("ERROR: no TclOO call context\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "nextto may only be called from inside a method", + -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + contextPtr = framePtr->clientData; + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr); + if (oPtr == NULL) { + TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr))); + goto gotError; + } else { + Class *classPtr = oPtr->classPtr; + struct MInvoke *miPtr; + int i; + const char *methodType; + + if (classPtr == NULL) { + TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + + for (i=contextPtr->index+1 ; icallPtr->numChain ; i++) { + miPtr = contextPtr->callPtr->chain + i; + if (!miPtr->isFilter && + miPtr->mPtr->declaringClassPtr == classPtr) { + newDepth = i; +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + } else { + fprintf(stdout, "%d: (%u) invoking ", + iPtr->numLevels, + (unsigned)(pc - codePtr->codeStart)); + } + for (i = 0; i < opnd; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + goto doInvokeNext; + } + } + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", + O2S(valuePtr))); + for (i=contextPtr->index ; i>=0 ; i--) { + miPtr = contextPtr->callPtr->chain + i; + if (miPtr->isFilter + || miPtr->mPtr->declaringClassPtr != classPtr) { + continue; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s implementation by \"%s\" not reachable from here", + methodType, TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s has no non-filter implementation by \"%s\"", + methodType, TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + case INST_TCLOO_NEXT: opnd = TclGetUInt1AtPtr(pc+1); + objv = &OBJ_AT_DEPTH(opnd - 1); framePtr = iPtr->varFramePtr; + skip = 1; TRACE(("%d => ", opnd)); if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { @@ -4580,7 +4683,8 @@ TEBCresume( } contextPtr = framePtr->clientData; - if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + newDepth = contextPtr->index + 1; + if (newDepth >= contextPtr->callPtr->numChain) { /* * We're at the end of the chain; generate an error message unless * the interpreter is being torn down, in which case we might be @@ -4605,33 +4709,31 @@ TEBCresume( Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); CACHE_STACK_INFO(); goto gotError; - } - #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + } else if (tclTraceExec >= 2) { int i; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("next_in_chain ")); } else { - fprintf(stdout, "%d: (%u) invoking next_in_chain ", + fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); } - for (i = 0; i < objc; i++) { + for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); fflush(stdout); - } #endif /*TCL_COMPILE_DEBUG*/ + } + doInvokeNext: bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); + ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv); } pcAdjustment = 2; @@ -4640,6 +4742,7 @@ TEBCresume( iPtr->varFramePtr = framePtr->callerVarPtr; pc += pcAdjustment; TEBC_YIELD(); + oPtr = contextPtr->oPtr; if (oPtr->flags & FILTER_HANDLING) { TclNRAddCallback(interp, FinalizeOONextFilter, @@ -4650,20 +4753,21 @@ TEBCresume( framePtr, contextPtr, INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip)); } - if (contextPtr->callPtr->chain[++contextPtr->index].isFilter + contextPtr->skip = skip; + contextPtr->index = newDepth; + if (contextPtr->callPtr->chain[newDepth].isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) { oPtr->flags |= FILTER_HANDLING; } else { oPtr->flags &= ~FILTER_HANDLING; } - contextPtr->skip = 1; + { register Method *const mPtr = - contextPtr->callPtr->chain[contextPtr->index].mPtr; + contextPtr->callPtr->chain[newDepth].mPtr; return mPtr->typePtr->callProc(mPtr->clientData, interp, - (Tcl_ObjectContext) contextPtr, opnd, - &OBJ_AT_DEPTH(opnd-1)); + (Tcl_ObjectContext) contextPtr, opnd, objv); } case INST_TCLOO_IS_OBJECT: diff --git a/generic/tclInt.h b/generic/tclInt.h index 3aaa30b..7932a58 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3592,6 +3592,9 @@ MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectNextToCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclOO.c b/generic/tclOO.c index 9a0682d..de00733 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -440,8 +440,9 @@ InitFoundation( cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", NULL, TclOONextObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectNextCmd; - Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", NULL, TclOONextToObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextToCmd; cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectSelfCmd; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 6084cf2..0b0516b 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -821,6 +821,7 @@ TclOONextToObjCmd( CallContext *contextPtr; int i; Tcl_Object object; + const char *methodType; /* * Start with sanity checks on the calling context to make sure that we @@ -886,19 +887,30 @@ TclOONextToObjCmd( * is on the chain but unreachable, or not on the chain at all. */ + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + for (i=contextPtr->index ; i>=0 ; i--) { struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "method implementation by \"%s\" not reachable from here", - TclGetString(objv[1]))); + "%s implementation by \"%s\" not reachable from here", + methodType, TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", + NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "method has no non-filter implementation by \"%s\"", - TclGetString(objv[1]))); + "%s has no non-filter implementation by \"%s\"", + methodType, TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); return TCL_ERROR; } -- cgit v0.12 From 128e4211ae5e41a3a0cbe8f651ee211618dd9a38 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 21 Jan 2014 15:07:59 +0000 Subject: implementation of [yieldto] in bytecode --- generic/tclBasic.c | 2 +- generic/tclCompCmdsSZ.c | 45 +++++++++++++++++++++++++++++++ generic/tclCompile.c | 7 +++++ generic/tclCompile.h | 4 ++- generic/tclExecute.c | 71 ++++++++++++++++++++++++++++++++++++++++++------- generic/tclInt.h | 3 +++ 6 files changed, 121 insertions(+), 11 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 7c02706..e355229 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -259,7 +259,7 @@ static const CmdInfo builtInCmds[] = { {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, - {"yieldto", NULL, NULL, TclNRYieldToObjCmd, CMD_IS_SAFE}, + {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE}, /* * Commands in the OS-interface. Note that many of these are unsafe. diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0f2790f..5c132b4 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -3447,6 +3447,51 @@ TclCompileYieldCmd( /* *---------------------------------------------------------------------- * + * TclCompileYieldToCmd -- + * + * Procedure called to compile the "yieldto" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "yieldto" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileYieldToCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + int i; + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + OP( NS_CURRENT); + for (i = 1 ; i < parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + OP4( LIST, i); + OP( YIELD_TO_INVOKE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * CompileUnaryOpCmd -- * * Utility routine to compile the unary operator commands. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index bd97e3e..f75ac83 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -631,6 +631,13 @@ InstructionDesc const tclInstructionTable[] = { * arguments (similar to invokeStk). * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ + {"yieldToInvoke", 1, 0, 0, {OPERAND_NONE}}, + /* Makes the current coroutine yield the value at the top of the + * stack, invoking the given command/args with resolution in the given + * namespace (all packed into a list), and places the list of values + * that are the response back on top of the stack when it resumes. + * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b047855..7994e2c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -793,8 +793,10 @@ typedef struct ByteCode { #define INST_TCLOO_NEXT 179 #define INST_TCLOO_NEXT_CLASS 180 +#define INST_YIELD_TO_INVOKE 181 + /* The last opcode */ -#define LAST_INST_OPCODE 180 +#define LAST_INST_OPCODE 181 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ac0ea12..575f227 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2494,9 +2494,12 @@ TEBCresume( TRACE_APPEND(("\n")); goto processExceptionReturn; - case INST_YIELD: { - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + { + CoroutineData *corPtr; + int yieldParameter; + case INST_YIELD: + corPtr = iPtr->execEnvPtr->corPtr; TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); if (!corPtr) { TRACE_APPEND(("ERROR: yield outside coroutine\n")); @@ -2510,11 +2513,63 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG - TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr); - if (traceInstructions) { - fprintf(stdout, "\n"); + if (tclTraceExec >= 2) { + if (traceInstructions) { + TRACE_APPEND(("YIELD...\n")); + } else { + fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + Tcl_GetString(OBJ_AT_TOS)); + } + fflush(stdout); + } +#endif + yieldParameter = 0; + Tcl_SetObjResult(interp, OBJ_AT_TOS); + goto doYield; + + case INST_YIELD_TO_INVOKE: + corPtr = iPtr->execEnvPtr->corPtr; + valuePtr = OBJ_AT_TOS; + if (!corPtr) { + TRACE(("[%.30s] => ERROR: yield outside coroutine\n", + O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto can only be called in a coroutine", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); + } else { + /* FIXME: What is the right thing to trace? */ + fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + Tcl_GetString(valuePtr)); + } + fflush(stdout); } #endif + + /* + * Install a tailcall record in the caller and continue with the + * yield. The yield is switched into multi-return mode (via the + * 'yieldParameter'). + */ + + Tcl_IncrRefCount(valuePtr); + iPtr->execEnvPtr = corPtr->callerEEPtr; + TclSetTailcall(interp, valuePtr); + iPtr->execEnvPtr = corPtr->eePtr; + yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ + + doYield: /* TIP #280: Record the last piece of info needed by * 'TclGetSrcInfoForPc', and push the frame. */ @@ -2529,11 +2584,8 @@ TEBCresume( pc++; cleanup = 1; TEBC_YIELD(); - - Tcl_SetObjResult(interp, OBJ_AT_TOS); TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - INT2PTR(0), NULL, NULL); - + INT2PTR(yieldParameter), NULL, NULL); return TCL_OK; } @@ -2553,6 +2605,7 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG + /* FIXME: What is the right thing to trace? */ { register int i; diff --git a/generic/tclInt.h b/generic/tclInt.h index 7932a58..6ddb015 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3688,6 +3688,9 @@ MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileYieldToCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 78b4196767371a557706d2d66f523fd240f61f12 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 21 Jan 2014 18:16:37 +0000 Subject: Silence compiler warnings. --- generic/tclListObj.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index d6ffa95..289cf2d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1031,8 +1031,8 @@ TclLindexList( { int index; /* Index into the list. */ - Tcl_Obj **indices; /* Array of list indices. */ - int indexCount; /* Size of the array of list indices. */ + Tcl_Obj **indices = NULL; /* Array of list indices. */ + int indexCount = -1; /* Size of the array of list indices. */ Tcl_Obj *indexListCopy; /* @@ -1117,8 +1117,8 @@ TclLindexFlat( Tcl_IncrRefCount(listPtr); for (i=0 ; i Date: Wed, 22 Jan 2014 09:07:45 +0000 Subject: [a90d9331bc]: must not crash when yieldto called in vanishing namespace --- generic/tclBasic.c | 18 ++++------ generic/tclExecute.c | 11 +++++++ tests/coroutine.test | 92 +++++++++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 105 insertions(+), 16 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e355229..cb9428c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8431,11 +8431,13 @@ TclNRYieldToObjCmd( return TCL_ERROR; } - /* - * Add the tailcall in the caller env, then just yield. - * - * This is essentially code from TclNRTailcallObjCmd - */ + if (((Namespace *) TclGetCurrentNamespace(interp))->flags & NS_DYING) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto called in deleted namespace", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", + NULL); + return TCL_ERROR; + } /* * Add the tailcall in the caller env, then just yield. @@ -8444,15 +8446,9 @@ TclNRYieldToObjCmd( */ listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("yieldto failed to find the proper namespace"); - } TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - /* * Add the callback in the caller's env, then instruct TEBC to yield. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 575f227..6749120 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2542,6 +2542,17 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; } + if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) { + TRACE(("[%.30s] => ERROR: yield in deleted\n", + O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto called in deleted namespace", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { diff --git a/tests/coroutine.test b/tests/coroutine.test index a360fd5..05b58c9 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -1,4 +1,4 @@ -# Commands covered: coroutine, yield, [info coroutine] +# Commands covered: coroutine, yield, yieldto, [info coroutine] # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files @@ -612,7 +612,6 @@ test coroutine-7.3 {yielding between coroutines} -body { } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} - test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { proc foo {a b} {catch yield; return 1} } -cleanup { @@ -620,7 +619,6 @@ test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { } -body { coroutine demo lsort -command foo {a b} } -result {b a} - test coroutine-7.5 {return codes} { set result {} foreach code {0 1 2 3 4 5} { @@ -628,14 +626,12 @@ test coroutine-7.5 {return codes} { } set result } {0 1 2 3 4 5} - test coroutine-7.6 {Early yield crashes} { proc foo args {} trace add execution foo enter {catch yield} coroutine demo foo rename foo {} } {} - test coroutine-7.7 {Bug 2486550} -setup { interp hide {} yield } -body { @@ -644,6 +640,92 @@ test coroutine-7.7 {Bug 2486550} -setup { demo interp expose {} yield } -result ok +test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} # cleanup -- cgit v0.12 From c9ae8d64d39dac7abeb842bc20b20d955e7d7b63 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 22 Jan 2014 09:14:57 +0000 Subject: minor tidying up --- generic/tclBasic.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cb9428c..46b532b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8416,8 +8416,7 @@ TclNRYieldToObjCmd( { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; + Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); @@ -8431,7 +8430,7 @@ TclNRYieldToObjCmd( return TCL_ERROR; } - if (((Namespace *) TclGetCurrentNamespace(interp))->flags & NS_DYING) { + if (((Namespace *) nsPtr)->flags & NS_DYING) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto called in deleted namespace", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", -- cgit v0.12 From 2be298f89da4601749fa18d4375bfaae181e2a66 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 Jan 2014 13:48:16 +0000 Subject: remove unused variable --- generic/tclBasic.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cb9428c..1aea752 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8417,7 +8417,6 @@ TclNRYieldToObjCmd( CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); -- cgit v0.12 From e3bde55a0f311f9f2dcf4a55a8149ac5843bb121 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 24 Jan 2014 17:38:59 +0000 Subject: Eliminate the copy to a staging buffer when that serves no functional purpose. --- generic/tclIO.c | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index f1d8909..13494ca 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3787,16 +3787,17 @@ WriteChars( consumedSomething = 1; while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) { consumedSomething = 0; - stage = statePtr->outputStage; - stageMax = statePtr->bufSize; - stageLen = stageMax; - - toWrite = stageLen; - if (toWrite > srcLen) { - toWrite = srcLen; - } if (translate) { + stage = statePtr->outputStage; + stageMax = statePtr->bufSize; + stageLen = stageMax; + + toWrite = stageLen; + if (toWrite > srcLen) { + toWrite = srcLen; + } + if (savedLF) { /* * A '\n' was left over from last call to TranslateOutputEOL() @@ -3822,8 +3823,9 @@ WriteChars( stageLen = stageMax; } } else { - memcpy(stage, src, toWrite); - stageLen = toWrite; + stage = (char *) src; + stageLen = srcLen; + toWrite = stageLen; } src += toWrite; srcLen -= toWrite; -- cgit v0.12 From 5d9939831c89629446b58080f3af09729cd719db Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 25 Jan 2014 21:41:12 +0000 Subject: sync tcl.m4 with Tk version --- unix/configure | 2 ++ unix/tcl.m4 | 2 ++ 2 files changed, 4 insertions(+) diff --git a/unix/configure b/unix/configure index 7f8922b..6800fe2 100755 --- a/unix/configure +++ b/unix/configure @@ -6939,6 +6939,7 @@ fi 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' 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 @@ -7652,6 +7653,7 @@ fi SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" + TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index e9795b8..c57111b 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1247,6 +1247,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ 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' AC_CACHE_CHECK(for Cygwin version of gcc, ac_cv_cygwin, AC_TRY_COMPILE([ @@ -1563,6 +1564,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" + TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" -- cgit v0.12 From 2585021472bf32a17c518f2a30daf06ba08b8b32 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 Jan 2014 11:04:57 +0000 Subject: WIP --- generic/tclIO.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index 13494ca..fdb0ddd 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3779,6 +3779,74 @@ WriteChars( translate = (statePtr->flags & CHANNEL_LINEBUFFERED) || (statePtr->outputTranslation != TCL_TRANSLATE_LF); +#if 0 + consumedSomething = 1; + while (consumedSomething && (srcLen + saved + endEncoding > 0)) { + void *lastNewLine; + int srcLimit; + + /* Get space to write into */ + bufPtr = statePtr->curOutPtr; + if (bufPtr == NULL) { + bufPtr = AllocChannelBuffer(statePtr->bufSize); + statePtr->curOutPtr = bufPtr; + if (saved) { + /* + * Here's some translated bytes left over from the last buffer + * that we need to stick at the beginning of this buffer. + */ + + memcpy(InsertPoint(bufPtr), safe, (size_t) saved); + bufPtr->nextAdded += saved; + saved = 0; + } + } + dst = InsertPoint(bufPtr); + dstLen = SpaceLeft(bufPtr); + + /* + * We have dstLen bytes to write to. The most source bytes + * that could possibly fill that is TCL_UTF_MAX * dstLen. + */ + + srcLimit = TCL_UTF_MAX * dstLen; + if (srcLen < srcLimit) { + srcLimit = srcLen; + } + lastNewLine = memchr(src, '\n', srcLimit); + + if (lastNewLine) { + srcLimit = lastNewLine - src; + } + + result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit, + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + + statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; + + if ((result != 0) && (srcRead + dstWrote == 0)) { + fprintf(stdout, "WDTH?\n"); fflush(stdout); + } + bufPtr->nextAdded += dstWrote; + if (IsBufferOverflowing(bufPtr)) { + /* + * When translating from UTF-8 to external encoding, we + * allowed the translation to produce a character that crossed + * the end of the output buffer, so that we would get a + * completely full buffer before flushing it. The extra bytes + * will be moved to the beginning of the next buffer. + */ + + saved = -SpaceLeft(bufPtr); + memcpy(safe, dst + dstLen, (size_t) saved); + bufPtr->nextAdded = bufPtr->bufLength; + } + + + } +#else /* * Loop over all UTF-8 characters in src, storing them in staging buffer * with proper EOL translation. @@ -3933,6 +4001,7 @@ WriteChars( } } } +#endif /* * If nothing was written and it happened because there was no progress in -- cgit v0.12 From d250eba26d431a600a252b3aa4f28df1c1106f8b Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 Jan 2014 18:51:59 +0000 Subject: Working code with no staging buffer use. --- generic/tclIO.c | 128 ++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 97 insertions(+), 31 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index fdb0ddd..7203739 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3756,18 +3756,21 @@ WriteChars( char *dst, *stage; int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote; int stageLen, toWrite, stageRead, endEncoding, result; - int consumedSomething, translate; + int consumedSomething, translate, flushed, needNlFlush; Tcl_Encoding encoding; char safe[BUFFER_PADDING]; + char *nextNewLine = NULL; if (srcLen) { WillWrite(chanPtr); } + flushed = 0; total = 0; sawLF = 0; savedLF = 0; saved = 0; + needNlFlush = 0; encoding = statePtr->encoding; /* @@ -3779,46 +3782,39 @@ WriteChars( translate = (statePtr->flags & CHANNEL_LINEBUFFERED) || (statePtr->outputTranslation != TCL_TRANSLATE_LF); -#if 0 +#if 1 + if (translate) { + nextNewLine = memchr(src, '\n', srcLen); + } consumedSomething = 1; while (consumedSomething && (srcLen + saved + endEncoding > 0)) { - void *lastNewLine; - int srcLimit; + int srcRead; + int srcLimit = srcLen; + + consumedSomething = 0; + if (nextNewLine) { + srcLimit = nextNewLine - src; + } /* Get space to write into */ bufPtr = statePtr->curOutPtr; if (bufPtr == NULL) { bufPtr = AllocChannelBuffer(statePtr->bufSize); statePtr->curOutPtr = bufPtr; - if (saved) { - /* - * Here's some translated bytes left over from the last buffer - * that we need to stick at the beginning of this buffer. - */ + } + if (saved) { + /* + * Here's some translated bytes left over from the last buffer + * that we need to stick at the beginning of this buffer. + */ - memcpy(InsertPoint(bufPtr), safe, (size_t) saved); - bufPtr->nextAdded += saved; - saved = 0; - } + memcpy(InsertPoint(bufPtr), safe, (size_t) saved); + bufPtr->nextAdded += saved; + saved = 0; } dst = InsertPoint(bufPtr); dstLen = SpaceLeft(bufPtr); - /* - * We have dstLen bytes to write to. The most source bytes - * that could possibly fill that is TCL_UTF_MAX * dstLen. - */ - - srcLimit = TCL_UTF_MAX * dstLen; - if (srcLen < srcLimit) { - srcLimit = srcLen; - } - lastNewLine = memchr(src, '\n', srcLimit); - - if (lastNewLine) { - srcLimit = lastNewLine - src; - } - result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit, statePtr->outputEncodingFlags, &statePtr->outputEncodingState, dst, @@ -3827,9 +3823,59 @@ WriteChars( statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; if ((result != 0) && (srcRead + dstWrote == 0)) { - fprintf(stdout, "WDTH?\n"); fflush(stdout); + /* We're reading from invalid/incomplete UTF-8 */ + break; } + + consumedSomething = 1; bufPtr->nextAdded += dstWrote; + src += srcRead; + srcLen -= srcRead; + total += dstWrote; + dst += dstWrote; + dstLen -= dstWrote; + + if (src == nextNewLine && dstLen > 0) { + static char crln[3] = "\r\n"; + char *nl = NULL; + int nlLen = 0; + + switch (statePtr->outputTranslation) { + case TCL_TRANSLATE_LF: + nl = crln + 1; + nlLen = 1; + break; + case TCL_TRANSLATE_CR: + nl = crln; + nlLen = 1; + break; + case TCL_TRANSLATE_CRLF: + nl = crln; + nlLen = 2; + break; + default: + Tcl_Panic("unknown output translation requested"); + break; + } + + result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen, + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + + if (srcRead != nlLen) { + Tcl_Panic("Can This Happen?"); + } + + bufPtr->nextAdded += dstWrote; + src++; + srcLen--; + total += dstWrote; + dst += dstWrote; + dstLen -= dstWrote; + nextNewLine = memchr(src, '\n', srcLen); + needNlFlush = 1; + } if (IsBufferOverflowing(bufPtr)) { /* * When translating from UTF-8 to external encoding, we @@ -3843,8 +3889,28 @@ WriteChars( memcpy(safe, dst + dstLen, (size_t) saved); bufPtr->nextAdded = bufPtr->bufLength; } - - + + if ((srcLen + saved == 0) && (result == 0)) { + endEncoding = 0; + } + + /* FLUSH ! */ + if (IsBufferFull(bufPtr)) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } + flushed += statePtr->bufSize; + if (saved == 0 || src[-1] != '\n') { + needNlFlush = 0; + } + } + } + if ((flushed < total) && (statePtr->flags & CHANNEL_UNBUFFERED || + (needNlFlush && statePtr->flags & CHANNEL_LINEBUFFERED))) { + SetFlag(statePtr, BUFFER_READY); + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } } #else /* -- cgit v0.12 From 2c2a7d737a40c8c1a97eb07d1396d5c48915bebf Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 Jan 2014 20:19:39 +0000 Subject: tidy things up --- generic/tclIO.c | 211 +++++--------------------------------------------------- 1 file changed, 17 insertions(+), 194 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 7203739..c7c11e7 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3752,46 +3752,30 @@ WriteChars( { ChannelState *statePtr = chanPtr->state; /* State info for channel */ - ChannelBuffer *bufPtr; - char *dst, *stage; - int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote; - int stageLen, toWrite, stageRead, endEncoding, result; - int consumedSomething, translate, flushed, needNlFlush; - Tcl_Encoding encoding; - char safe[BUFFER_PADDING]; char *nextNewLine = NULL; + int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0; + Tcl_Encoding encoding = statePtr->encoding; if (srcLen) { WillWrite(chanPtr); } - flushed = 0; - total = 0; - sawLF = 0; - savedLF = 0; - saved = 0; - needNlFlush = 0; - encoding = statePtr->encoding; - /* * Write the terminated escape sequence even if srcLen is 0. */ endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0); - translate = (statePtr->flags & CHANNEL_LINEBUFFERED) - || (statePtr->outputTranslation != TCL_TRANSLATE_LF); - -#if 1 - if (translate) { + if ((statePtr->flags & CHANNEL_LINEBUFFERED) + || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) { nextNewLine = memchr(src, '\n', srcLen); } - consumedSomething = 1; - while (consumedSomething && (srcLen + saved + endEncoding > 0)) { - int srcRead; - int srcLimit = srcLen; - consumedSomething = 0; + while (srcLen + saved + endEncoding > 0) { + ChannelBuffer *bufPtr; + char *dst, safe[BUFFER_PADDING]; + int result, srcRead, dstLen, dstWrote, srcLimit = srcLen; + if (nextNewLine) { srcLimit = nextNewLine - src; } @@ -3820,14 +3804,18 @@ WriteChars( &statePtr->outputEncodingState, dst, dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + /* See chan-io-1.[89]. Tcl Bug 506297. */ statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; - if ((result != 0) && (srcRead + dstWrote == 0)) { + if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { /* We're reading from invalid/incomplete UTF-8 */ + if (total == 0) { + Tcl_SetErrno(EINVAL); + return -1; + } break; } - consumedSomething = 1; bufPtr->nextAdded += dstWrote; src += srcRead; srcLen -= srcRead; @@ -3876,6 +3864,7 @@ WriteChars( nextNewLine = memchr(src, '\n', srcLen); needNlFlush = 1; } + if (IsBufferOverflowing(bufPtr)) { /* * When translating from UTF-8 to external encoding, we @@ -3890,11 +3879,10 @@ WriteChars( bufPtr->nextAdded = bufPtr->bufLength; } - if ((srcLen + saved == 0) && (result == 0)) { + if ((srcLen + saved == 0) && (result == TCL_OK)) { endEncoding = 0; } - /* FLUSH ! */ if (IsBufferFull(bufPtr)) { if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; @@ -3912,172 +3900,7 @@ WriteChars( return -1; } } -#else - /* - * Loop over all UTF-8 characters in src, storing them in staging buffer - * with proper EOL translation. - */ - - consumedSomething = 1; - while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) { - consumedSomething = 0; - - if (translate) { - stage = statePtr->outputStage; - stageMax = statePtr->bufSize; - stageLen = stageMax; - - toWrite = stageLen; - if (toWrite > srcLen) { - toWrite = srcLen; - } - - if (savedLF) { - /* - * A '\n' was left over from last call to TranslateOutputEOL() - * and we need to store it in the staging buffer. If the channel - * is line-based, we will need to flush the output buffer (after - * translating the staging buffer). - */ - - *stage++ = '\n'; - stageLen--; - sawLF++; - } - if (TranslateOutputEOL(statePtr, stage, src, &stageLen, &toWrite)) { - sawLF++; - } - - stage -= savedLF; - stageLen += savedLF; - savedLF = 0; - - if (stageLen > stageMax) { - savedLF = 1; - stageLen = stageMax; - } - } else { - stage = (char *) src; - stageLen = srcLen; - toWrite = stageLen; - } - src += toWrite; - srcLen -= toWrite; - - /* - * Loop over all UTF-8 characters in staging buffer, converting them - * to external encoding, storing them in output buffer. - */ - - while (stageLen + saved + endEncoding > 0) { - bufPtr = statePtr->curOutPtr; - if (bufPtr == NULL) { - bufPtr = AllocChannelBuffer(statePtr->bufSize); - statePtr->curOutPtr = bufPtr; - } - dst = InsertPoint(bufPtr); - dstLen = SpaceLeft(bufPtr); - if (saved != 0) { - /* - * Here's some translated bytes left over from the last buffer - * that we need to stick at the beginning of this buffer. - */ - - memcpy(dst, safe, (size_t) saved); - bufPtr->nextAdded += saved; - dst += saved; - dstLen -= saved; - saved = 0; - } - - result = Tcl_UtfToExternal(NULL, encoding, stage, stageLen, - statePtr->outputEncodingFlags, - &statePtr->outputEncodingState, dst, - dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL); - - /* - * Fix for SF #506297, reported by Martin Forssen - * . - * - * The encoding chosen in the script exposing the bug writes out - * three intro characters when TCL_ENCODING_START is set, but does - * not consume any input as TCL_ENCODING_END is cleared. As some - * output was generated the enclosing loop calls UtfToExternal - * again, again with START set. Three more characters in the out - * and still no use of input ... To break this infinite loop we - * remove TCL_ENCODING_START from the set of flags after the first - * call (no condition is required, the later calls remove an unset - * flag, which is a no-op). This causes the subsequent calls to - * UtfToExternal to consume and convert the actual input. - */ - - statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; - - /* - * The following code must be executed only when result is not 0. - */ - - if ((result != 0) && (stageRead + dstWrote == 0)) { - /* - * We have an incomplete UTF-8 character at the end of the - * staging buffer. It will get moved to the beginning of the - * staging buffer followed by more bytes from src. - */ - - src -= stageLen; - srcLen += stageLen; - stageLen = 0; - savedLF = 0; - break; - } - bufPtr->nextAdded += dstWrote; - if (IsBufferOverflowing(bufPtr)) { - /* - * When translating from UTF-8 to external encoding, we - * allowed the translation to produce a character that crossed - * the end of the output buffer, so that we would get a - * completely full buffer before flushing it. The extra bytes - * will be moved to the beginning of the next buffer. - */ - - saved = -SpaceLeft(bufPtr); - memcpy(safe, dst + dstLen, (size_t) saved); - bufPtr->nextAdded = bufPtr->bufLength; - } - if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { - return -1; - } - - total += dstWrote; - stage += stageRead; - stageLen -= stageRead; - sawLF = 0; - - consumedSomething = 1; - - /* - * If all translated characters are written to the buffer, - * endEncoding is set to 0 because the escape sequence may be - * output. - */ - - if ((stageLen + saved == 0) && (result == 0)) { - endEncoding = 0; - } - } - } -#endif - - /* - * If nothing was written and it happened because there was no progress in - * the UTF conversion, we throw an error. - */ - - if (!consumedSomething && (total == 0)) { - Tcl_SetErrno(EINVAL); - return -1; - } return total; } -- cgit v0.12 From c53002fe3b7577110aed9296873bfde668ea253f Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 Jan 2014 20:23:26 +0000 Subject: The outputStage field is now unused, so never allocate it. --- generic/tclIO.c | 29 ----------------------------- 1 file changed, 29 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index c7c11e7..4ae9ec0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1489,12 +1489,7 @@ Tcl_CreateChannel( statePtr->timer = NULL; statePtr->csPtrR = NULL; statePtr->csPtrW = NULL; - statePtr->outputStage = NULL; - if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { - statePtr->outputStage = (char *) - ckalloc((unsigned) (statePtr->bufSize + 2)); - } /* * As we are creating the channel, it is obviously the top for now. @@ -2757,10 +2752,6 @@ CloseChannel( } Tcl_FreeEncoding(statePtr->encoding); - if (statePtr->outputStage != NULL) { - ckfree((char *) statePtr->outputStage); - statePtr->outputStage = NULL; - } } /* @@ -7151,15 +7142,6 @@ Tcl_SetChannelBufferSize( statePtr = ((Channel *) chan)->state; statePtr->bufSize = sz; - - if (statePtr->outputStage != NULL) { - ckfree((char *) statePtr->outputStage); - statePtr->outputStage = NULL; - } - if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { - statePtr->outputStage = (char *) - ckalloc((unsigned) (statePtr->bufSize + 2)); - } } /* @@ -7800,17 +7782,6 @@ Tcl_SetChannelOption( statePtr->inQueueTail = NULL; } - /* - * If encoding or bufsize changes, need to update output staging buffer. - */ - - if (statePtr->outputStage != NULL) { - ckfree(statePtr->outputStage); - statePtr->outputStage = NULL; - } - if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { - statePtr->outputStage = ckalloc((unsigned) (statePtr->bufSize + 2)); - } return TCL_OK; } -- cgit v0.12 From 6597355ad8e93ef19d16f6fea501506b141946fb Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 29 Jan 2014 13:59:32 +0000 Subject: Compile [string is] with character classes in a non-awful way. Needs more work to make resulting bytecode disassemble nicely. --- generic/tclCompCmdsSZ.c | 99 ++++++++++++++++++++++++++++++++++++++++++++----- generic/tclCompile.c | 5 +++ generic/tclCompile.h | 37 +++++++++++++++++- generic/tclExecute.c | 19 ++++++++++ 4 files changed, 150 insertions(+), 10 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 1a69a89..639b4a5 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -452,6 +452,7 @@ TclCompileStringIsCmd( STR_IS_XDIGIT }; int t, range, allowEmpty = 0, end; + InstStringClassType strClassType; Tcl_Obj *isClass; if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { @@ -486,7 +487,7 @@ TclCompileStringIsCmd( tokenPtr = TokenAfter(tokenPtr); if (parsePtr->numWords == 3) { - allowEmpty = (t != STR_IS_LIST); + allowEmpty = 1; } else { if (!GotLiteral(tokenPtr, "-strict")) { return TCL_ERROR; @@ -496,30 +497,77 @@ TclCompileStringIsCmd( #undef GotLiteral /* - * Some types are not currently handled. Character classes are a prime - * example of this. + * Compile the code. There are several main classes of check here. + * 1. Character classes + * 2. Booleans + * 3. Integers + * 4. Floats + * 5. Lists */ + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + switch ((enum isClasses) t) { case STR_IS_ALNUM: + strClassType = STR_CLASS_ALNUM; + goto compileStrClass; case STR_IS_ALPHA: + strClassType = STR_CLASS_ALPHA; + goto compileStrClass; case STR_IS_ASCII: + strClassType = STR_CLASS_ASCII; + goto compileStrClass; case STR_IS_CONTROL: + strClassType = STR_CLASS_CONTROL; + goto compileStrClass; case STR_IS_DIGIT: + strClassType = STR_CLASS_DIGIT; + goto compileStrClass; case STR_IS_GRAPH: + strClassType = STR_CLASS_GRAPH; + goto compileStrClass; case STR_IS_LOWER: + strClassType = STR_CLASS_LOWER; + goto compileStrClass; case STR_IS_PRINT: + strClassType = STR_CLASS_PRINT; + goto compileStrClass; case STR_IS_PUNCT: + strClassType = STR_CLASS_PUNCT; + goto compileStrClass; case STR_IS_SPACE: + strClassType = STR_CLASS_SPACE; + goto compileStrClass; case STR_IS_UPPER: + strClassType = STR_CLASS_UPPER; + goto compileStrClass; case STR_IS_WORD: + strClassType = STR_CLASS_WORD; + goto compileStrClass; case STR_IS_XDIGIT: - return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + strClassType = STR_CLASS_XDIGIT; + compileStrClass: + if (allowEmpty) { + OP1( STR_CLASS, strClassType); + } else { + int over, over2; + + OP( DUP); + OP1( STR_CLASS, strClassType); + JUMP1( JUMP_TRUE, over); + OP( POP); + PUSH( "0"); + JUMP1( JUMP, over2); + FIXJUMP1(over); + PUSH( ""); + OP( STR_NEQ); + FIXJUMP1(over2); + } + return TCL_OK; case STR_IS_BOOL: case STR_IS_FALSE: case STR_IS_TRUE: - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); OP( TRY_CVT_TO_BOOLEAN); switch (t) { int over, over2; @@ -569,7 +617,6 @@ TclCompileStringIsCmd( case STR_IS_DOUBLE: { int satisfied, isEmpty; - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); if (allowEmpty) { OP( DUP); PUSH( ""); @@ -598,7 +645,6 @@ TclCompileStringIsCmd( case STR_IS_INT: case STR_IS_WIDE: case STR_IS_ENTIER: - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); if (allowEmpty) { int testNumType; @@ -638,7 +684,6 @@ TclCompileStringIsCmd( return TCL_OK; case STR_IS_LIST: - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); @@ -653,7 +698,8 @@ TclCompileStringIsCmd( OP( LNOT); return TCL_OK; } - return TCL_ERROR; + + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); } int @@ -1171,6 +1217,41 @@ TclCompileStringToTitleCmd( } /* + * Support definitions for the [string is] compilation. + */ + +static int +UniCharIsAscii( + int character) +{ + return (character >= 0) && (character < 0x80); +} + +static int +UniCharIsHexDigit( + int character) +{ + return (character >= 0) && (character < 0x80) && isxdigit(character); +} + +StringClassDesc const tclStringClassTable[] = { + {"alnum", Tcl_UniCharIsAlnum}, + {"alpha", Tcl_UniCharIsAlpha}, + {"ascii", UniCharIsAscii}, + {"control", Tcl_UniCharIsControl}, + {"digit", Tcl_UniCharIsDigit}, + {"graph", Tcl_UniCharIsGraph}, + {"lower", Tcl_UniCharIsLower}, + {"print", Tcl_UniCharIsPrint}, + {"punct", Tcl_UniCharIsPunct}, + {"space", Tcl_UniCharIsSpace}, + {"upper", Tcl_UniCharIsUpper}, + {"word", Tcl_UniCharIsWordChar}, + {"xdigit", UniCharIsHexDigit}, + {NULL, NULL} +}; + +/* *---------------------------------------------------------------------- * * TclCompileSubstCmd -- diff --git a/generic/tclCompile.c b/generic/tclCompile.c index fdc3e26..08a7a4c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -644,6 +644,11 @@ InstructionDesc const tclInstructionTable[] = { {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}}, /* Try converting stktop to boolean if possible. No errors. * Stack: ... value => ... value isStrictBool */ + {"strclass", 2, 0, 1, {OPERAND_UINT1}}, + /* See if all the characters of the given string are a member of the + * specified (by opnd) character class. Note that an empty string will + * satisfy the class check (standard definition of "all"). + * Stack: ... stringValue => ... boolean */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index d6d515d..502a2e6 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -797,9 +797,10 @@ typedef struct ByteCode { #define INST_NUM_TYPE 182 #define INST_TRY_CVT_TO_BOOLEAN 183 +#define INST_STR_CLASS 184 /* The last opcode */ -#define LAST_INST_OPCODE 183 +#define LAST_INST_OPCODE 184 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -844,6 +845,40 @@ typedef struct InstructionDesc { MODULE_SCOPE InstructionDesc const tclInstructionTable[]; /* + * Constants used by INST_STRING_CLASS to indicate character classes. These + * correspond closely by name with what [string is] can support, but there is + * no requirement to keep the values the same. + */ + +typedef enum InstStringClassType { + STR_CLASS_ALNUM, /* Unicode alphabet or digit characters. */ + STR_CLASS_ALPHA, /* Unicode alphabet characters. */ + STR_CLASS_ASCII, /* Characters in range U+000000..U+00007F. */ + STR_CLASS_CONTROL, /* Unicode control characters. */ + STR_CLASS_DIGIT, /* Unicode digit characters. */ + STR_CLASS_GRAPH, /* Unicode printing characters, excluding + * space. */ + STR_CLASS_LOWER, /* Unicode lower-case alphabet characters. */ + STR_CLASS_PRINT, /* Unicode printing characters, including + * spaces. */ + STR_CLASS_PUNCT, /* Unicode punctuation characters. */ + STR_CLASS_SPACE, /* Unicode space characters. */ + STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */ + STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector + * punctuation) characters. */ + STR_CLASS_XDIGIT /* Characters that can be used as digits in + * hexadecimal numbers ([0-9A-Fa-f]). */ +} InstStringClassType; + +typedef struct StringClassDesc { + const char *name; /* Name of the class. */ + int (*comparator)(int); /* Function to test if a single unicode + * character is a member of the class. */ +} StringClassDesc; + +MODULE_SCOPE StringClassDesc const tclStringClassTable[]; + +/* * Compilation of some Tcl constructs such as if commands and the logical or * (||) and logical and (&&) operators in expressions requires the generation * of forward jumps. Since the PC target of these jumps isn't known when the diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 916de17..58d85e1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5810,6 +5810,25 @@ TEBCresume( TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); + + case INST_STR_CLASS: + opnd = TclGetInt1AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; + TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, + O2S(valuePtr))); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + match = 1; + if (length > 0) { + end = ustring1 + length; + for (p=ustring1 ; p Date: Wed, 29 Jan 2014 23:18:58 +0000 Subject: Squashed C99 syntax breaking the native AIX cc. --- generic/tclAssembly.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7b775a9..55a0c3f 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -50,7 +50,7 @@ typedef enum BasicBlockCatchState { BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */ BBCS_NONE, /* Block is outside of any catch */ BBCS_INCATCH, /* Block is within a catch context */ - BBCS_CAUGHT, /* Block is within a catch context and + BBCS_CAUGHT /* Block is within a catch context and * may be executed after an exception fires */ } BasicBlockCatchState; @@ -121,7 +121,7 @@ enum BasicBlockFlags { * marking it as the start of a 'catch' * sequence. The 'jumpTarget' is the exception * exit from the catch block. */ - BB_ENDCATCH = (1 << 5), /* Block ends with an 'endCatch' instruction, + BB_ENDCATCH = (1 << 5) /* Block ends with an 'endCatch' instruction, * unwinding the catch from the exception * stack. */ }; @@ -184,7 +184,7 @@ typedef enum TalInstType { * produces N */ ASSEM_SINT1, /* One 1-byte signed-integer operand * (INCR_STK_IMM) */ - ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by + ASSEM_SINT4_LVT4 /* Signed 4-byte integer operand followed by * LVT entry. Fixed arity */ } TalInstType; -- cgit v0.12 From 63d77c004603234da017ab55759d48c60e2a8ed0 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 30 Jan 2014 11:02:51 +0000 Subject: win/tclWinChan.c Tcl_InitNotifier: Bug [2413550] Avoid reopening of serial channels which causes issues with Bluetooth virtual com. Patch by Rolf Schroedter. --- ChangeLog | 6 +++ win/tclWinChan.c | 151 ++++++++++++++++++++++++++++++++++++++++++++++++++++- win/tclWinInt.h | 2 +- win/tclWinSerial.c | 25 +++++---- 4 files changed, 171 insertions(+), 13 deletions(-) diff --git a/ChangeLog b/ChangeLog index fd8c7c7..aec77d9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -7,6 +7,12 @@ this log file. You may still find useful things in it, but the Timeline is a better first place to look now. ============================================================================ +2014-01-30 Harald Oehlmann + + * win/tclWinChan.c Tcl_InitNotifier: Bug [2413550] + Avoid reopening of serial channels which causes issues with + Bluetooth virtual com. Patch by Rolf Schroedter. + 2013-08-30 Don Porter * generic/tcl.h: Bump to 8.5.15 for release. diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 89d898f..19e3655 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -95,7 +95,7 @@ static void FileThreadActionProc(ClientData instanceData, static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static DWORD FileGetType(HANDLE handle); - +static int NativeIsComPort(CONST TCHAR *nativeName); /* * This structure describes the channel type structure for file based IO. */ @@ -904,6 +904,33 @@ TclpOpenFileChannel( } /* + * [2413550] Avoid double-open of serial ports on Windows + * Special handling for Windows serial ports by a "name-hint" + * to directly open it with the OVERLAPPED flag set. + */ + + if( NativeIsComPort(nativeName) ) { + + handle = TclWinSerialOpen(INVALID_HANDLE_VALUE, nativeName, accessMode); + if (handle == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open serial \"", + TclGetString(pathPtr), "\": ", + Tcl_PosixError(interp), NULL); + } + return NULL; + } + + /* + * For natively named Windows serial ports we are done. + */ + channel = TclWinOpenSerialChannel(handle, channelName, + channelPermissions); + + return channel; + } + /* * Set up the file sharing mode. We want to allow simultaneous access. */ @@ -935,11 +962,15 @@ TclpOpenFileChannel( switch (FileGetType(handle)) { case FILE_TYPE_SERIAL: /* + * Natively named serial ports "com1-9", "\\\\.\\comXX" are + * already done with the code above. + * Here we handle all other serial port names. + * * Reopen channel for OVERLAPPED operation. Normally this shouldn't * fail, because the channel exists. */ - handle = TclWinSerialReopen(handle, nativeName, accessMode); + handle = TclWinSerialOpen(handle, nativeName, accessMode); if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); if (interp != (Tcl_Interp *) NULL) { @@ -1476,6 +1507,122 @@ FileGetType( return type; } + /* + *---------------------------------------------------------------------- + * + * 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 + * to detect serialness after the fact. + * The following patterns cover common serial port names: + * COM[1-9]:? + * //./COM[0-9]+ + * \\.\COM[0-9]+ + * + * Results: + * 1 = serial port, 0 = not. + * + *---------------------------------------------------------------------- + */ + +static int +NativeIsComPort( + const TCHAR *nativePath) /* Path of file to access, native encoding. */ +{ + /* + * Use wide-char or plain character case-insensitive comparison + */ + if (tclWinProcs->useWide) { + const WCHAR *p = (const WCHAR *) nativePath; + int i, len = wcslen(p); + + /* + * 1. Look for com[1-9]:? + */ + + if ( (len >= 4) && (len <= 5) + && (_wcsnicmp(p, L"com", 3) == 0) ) { + /* + * The 4th character must be a digit 1..9 optionally followed by a ":" + */ + + 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]+ + */ + + if ( (len >= 8) && ( + (_wcsnicmp(p, L"//./com", 7) == 0) + || (_wcsnicmp(p, L"\\\\.\\com", 7) == 0) ) ) + { + /* + * Charaters 8..end must be a digits 0..9 + */ + + for ( i=7; i '9') ) { + return 0; + } + } + return 1; + } + + } else { + const char *p = (const char *) nativePath; + int i, len = strlen(p); + + /* + * 1. Look for com[1-9]:? + */ + + if ( (len >= 4) && (len <= 5) + && (strnicmp(p, "com", 3) == 0) ) { + /* + * The 4th character must be a digit 1..9 optionally followed by a ":" + */ + + if ( (p[3] < '1') || (p[3] > '9') ) { + return 0; + } + if ( (len == 5) && (p[4] != ':') ) { + return 0; + } + return 1; + } + + /* + * 2. Look for //./com[0-9]+ or \\.\com[0-9]+ + */ + + if ( (len >= 8) && ( + (strnicmp(p, "//./com", 7) == 0) + || (strnicmp(p, "\\\\.\\com", 7) == 0) ) ) + { + /* + * Charaters 8..end must be a digits 0..9 + */ + + for ( i=7; i '9') ) { + return 0; + } + } + return 1; + } + } + return 0; +} + /* * Local Variables: * mode: c diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 3d5e275..ccf48bb 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -187,7 +187,7 @@ MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName, MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle, char *channelName, int permissions); MODULE_SCOPE void TclWinResetInterfaceEncodings(); -MODULE_SCOPE HANDLE TclWinSerialReopen(HANDLE handle, CONST TCHAR *name, +MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, CONST TCHAR *name, DWORD access); MODULE_SCOPE int TclWinSymLinkCopyDirectory(CONST TCHAR* LinkOriginal, CONST TCHAR* LinkCopy); diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index d5244ac..312a2f8 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1410,23 +1410,22 @@ SerialWriterThread( /* *---------------------------------------------------------------------- * - * TclWinSerialReopen -- + * TclWinSerialOpen -- * - * Reopens the serial port with the OVERLAPPED FLAG set + * Opens or Reopens the serial port with the OVERLAPPED FLAG set * * Results: - * Returns the new handle, or INVALID_HANDLE_VALUE. Normally there - * shouldn't be any error, because the same channel has previously been - * succeesfully opened. + * Returns the new handle, or INVALID_HANDLE_VALUE. + * I an existing channel is specified it is closed and reopened. * * Side effects: - * May close the original handle + * May close/reopen the original handle * *---------------------------------------------------------------------- */ HANDLE -TclWinSerialReopen( +TclWinSerialOpen( HANDLE handle, CONST TCHAR *name, DWORD access) @@ -1434,16 +1433,22 @@ TclWinSerialReopen( SerialInit(); /* + * If an open channel is specified, close it + */ + + if ( handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) { + return INVALID_HANDLE_VALUE; + } + + /* * Multithreaded I/O needs the overlapped flag set otherwise * ClearCommError blocks under Windows NT/2000 until serial output is * finished */ - if (CloseHandle(handle) == FALSE) { - return INVALID_HANDLE_VALUE; - } handle = (*tclWinProcs->createFileProc)(name, access, 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); + return handle; } -- cgit v0.12 From 2c00f457ae3e80cc8d352c8cc08118f619f52562 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Jan 2014 14:44:56 +0000 Subject: Fix [22c10c8e79]: core-8-5: msvc6 build: "Side by Side" error --- win/makefile.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index 4466439..152cc66 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -902,7 +902,7 @@ $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in @nmakehlp -s << $** >$@ @MACHINE@ $(MACHINE:IX86=X86) -@TCL_WIN_VERSION@ $(TCL_DOTVERSION).0.0 +@TCL_WIN_VERSION@ $(DOTVERSION).0.0 << #--------------------------------------------------------------------- -- cgit v0.12 From 248247d828d4ac688024a9dadfe7a284f9dbc24c Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Jan 2014 18:31:39 +0000 Subject: Refactor WriteChars() and WriteBytes() into simple wrappers of a common routine Write(). --- generic/tclEncoding.c | 2 ++ generic/tclIO.c | 48 +++++++++++++++++++++++++++++++++++------------- generic/tclInt.h | 2 ++ 3 files changed, 39 insertions(+), 13 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index c2f1b4b..c303dd1 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -182,6 +182,7 @@ TCL_DECLARE_MUTEX(encodingMutex) static Tcl_Encoding defaultEncoding; static Tcl_Encoding systemEncoding; +Tcl_Encoding tclIdentityEncoding; /* * The following variable is used in the sparse matrix code for a @@ -566,6 +567,7 @@ TclInitEncodingSubsystem(void) type.clientData = NULL; defaultEncoding = Tcl_CreateEncoding(&type); + tclIdentityEncoding = Tcl_GetEncoding(NULL, type.encodingName); systemEncoding = Tcl_GetEncoding(NULL, type.encodingName); type.encodingName = "utf-8"; diff --git a/generic/tclIO.c b/generic/tclIO.c index 4ae9ec0..78ad629 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -200,6 +200,7 @@ static int FilterInputBytes(Channel *chanPtr, static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush); static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr); +static Tcl_Encoding GetBinaryEncoding(); static void FreeBinaryEncoding(ClientData clientData); static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp); static int GetInput(Channel *chanPtr); @@ -222,6 +223,8 @@ static int TranslateInputEOL(ChannelState *statePtr, char *dst, static int TranslateOutputEOL(ChannelState *statePtr, char *dst, const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); +static int Write(Channel *chanPtr, const char *src, + int srcLen, Tcl_Encoding encoding); static int WriteBytes(Channel *chanPtr, const char *src, int srcLen); static int WriteChars(Channel *chanPtr, const char *src, @@ -3640,6 +3643,9 @@ WriteBytes( const char *src, /* Bytes to write. */ int srcLen) /* Number of bytes to write. */ { +#if 1 + return Write(chanPtr, src, srcLen, tclIdentityEncoding); +#else ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; @@ -3712,6 +3718,7 @@ WriteBytes( sawLF = 0; } return total; +#endif } /* @@ -3736,16 +3743,16 @@ WriteBytes( */ static int -WriteChars( +Write( Channel *chanPtr, /* The channel to buffer output for. */ const char *src, /* UTF-8 string to write. */ - int srcLen) /* Length of UTF-8 string in bytes. */ + int srcLen, /* Length of UTF-8 string in bytes. */ + Tcl_Encoding encoding) { ChannelState *statePtr = chanPtr->state; /* State info for channel */ char *nextNewLine = NULL; int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0; - Tcl_Encoding encoding = statePtr->encoding; if (srcLen) { WillWrite(chanPtr); @@ -3894,6 +3901,15 @@ WriteChars( return total; } + +static int +WriteChars( + Channel *chanPtr, /* The channel to buffer output for. */ + const char *src, /* UTF-8 string to write. */ + int srcLen) /* Length of UTF-8 string in bytes. */ +{ + return Write(chanPtr, src, srcLen, chanPtr->state->encoding); +} /* *--------------------------------------------------------------------------- @@ -4197,16 +4213,7 @@ Tcl_GetsObj( */ if (encoding == NULL) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (tsdPtr->binaryEncoding == NULL) { - tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); - Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL); - } - encoding = tsdPtr->binaryEncoding; - if (encoding == NULL) { - Tcl_Panic("attempted gets on binary channel where no iso8859-1 encoding available"); - } + encoding = GetBinaryEncoding(); } /* @@ -4747,6 +4754,21 @@ FreeBinaryEncoding( tsdPtr->binaryEncoding = NULL; } } + +static Tcl_Encoding +GetBinaryEncoding() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->binaryEncoding == NULL) { + tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); + Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL); + } + if (tsdPtr->binaryEncoding == NULL) { + Tcl_Panic("binary encoding is not available"); + } + return tsdPtr->binaryEncoding; +} /* *--------------------------------------------------------------------------- diff --git a/generic/tclInt.h b/generic/tclInt.h index dc28b97..b45f8e3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2382,6 +2382,8 @@ MODULE_SCOPE char *tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier; +MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; + /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. -- cgit v0.12 From 050c8a639fb8fb89e5febcb7564310ee16de2461 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Jan 2014 18:45:11 +0000 Subject: Simplification and cleanup enabled by last commit. --- generic/tclIO.c | 308 ++------------------------------------------------------ 1 file changed, 7 insertions(+), 301 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 78ad629..dd9f1dc 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -165,8 +165,6 @@ static ChannelBuffer * AllocChannelBuffer(int length); static void ChannelTimerProc(ClientData clientData); static int CheckChannelErrors(ChannelState *statePtr, int direction); -static int CheckFlush(Channel *chanPtr, ChannelBuffer *bufPtr, - int newlineFlag); static int CheckForDeadChannel(Tcl_Interp *interp, ChannelState *statePtr); static void CheckForStdChannelsBeingClosed(Tcl_Channel chan); @@ -220,20 +218,19 @@ static int SetBlockMode(Tcl_Interp *interp, Channel *chanPtr, static void StopCopy(CopyState *csPtr); static int TranslateInputEOL(ChannelState *statePtr, char *dst, const char *src, int *dstLenPtr, int *srcLenPtr); -static int TranslateOutputEOL(ChannelState *statePtr, char *dst, - const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); static int Write(Channel *chanPtr, const char *src, int srcLen, Tcl_Encoding encoding); -static int WriteBytes(Channel *chanPtr, const char *src, - int srcLen); -static int WriteChars(Channel *chanPtr, const char *src, - int srcLen); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); static int WillRead(Channel *chanPtr); +#define WriteChars(chanPtr, src, srcLen) \ + Write(chanPtr, src, srcLen, chanPtr->state->encoding) +#define WriteBytes(chanPtr, src, srcLen) \ + Write(chanPtr, src, srcLen, tclIdentityEncoding) + /* * Simplifying helper macros. All may use their argument(s) multiple times. * The ANSI C "prototypes" for the macros are listed below, together with a @@ -3619,114 +3616,9 @@ static int WillRead(Channel *chanPtr) /* *---------------------------------------------------------------------- * - * WriteBytes -- - * - * Write a sequence of bytes into an output buffer, may queue the buffer - * for output if it gets full, and also remembers whether the current - * buffer is ready e.g. if it contains a newline and we are in line - * buffering mode. - * - * Results: - * The number of bytes written or -1 in case of error. If -1, - * Tcl_GetErrno will return the error code. - * - * Side effects: - * May buffer up output and may cause output to be produced on the - * channel. + * Write -- * - *---------------------------------------------------------------------- - */ - -static int -WriteBytes( - Channel *chanPtr, /* The channel to buffer output for. */ - const char *src, /* Bytes to write. */ - int srcLen) /* Number of bytes to write. */ -{ -#if 1 - return Write(chanPtr, src, srcLen, tclIdentityEncoding); -#else - ChannelState *statePtr = chanPtr->state; - /* State info for channel */ - ChannelBuffer *bufPtr; - char *dst; - int dstMax, sawLF, savedLF, total, dstLen, toWrite, translate; - - if (srcLen) { - WillWrite(chanPtr); - } - - total = 0; - sawLF = 0; - savedLF = 0; - translate = (statePtr->flags & CHANNEL_LINEBUFFERED) - || (statePtr->outputTranslation != TCL_TRANSLATE_LF); - - /* - * Loop over all bytes in src, storing them in output buffer with proper - * EOL translation. - */ - - while (srcLen + savedLF > 0) { - bufPtr = statePtr->curOutPtr; - if (bufPtr == NULL) { - bufPtr = AllocChannelBuffer(statePtr->bufSize); - statePtr->curOutPtr = bufPtr; - } - dst = InsertPoint(bufPtr); - dstMax = SpaceLeft(bufPtr); - dstLen = dstMax; - - toWrite = dstLen; - if (toWrite > srcLen) { - toWrite = srcLen; - } - - if (translate) { - if (savedLF) { - /* - * A '\n' was left over from last call to TranslateOutputEOL() - * and we need to store it in this buffer. If the channel is - * line-based, we will need to flush it. - */ - - *dst++ = '\n'; - dstLen--; - sawLF++; - } - if (TranslateOutputEOL(statePtr, dst, src, &dstLen, &toWrite)) { - sawLF++; - } - dstLen += savedLF; - savedLF = 0; - if (dstLen > dstMax) { - savedLF = 1; - dstLen = dstMax; - } - } else { - memcpy(dst, src, toWrite); - dstLen = toWrite; - } - - bufPtr->nextAdded += dstLen; - if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { - return -1; - } - total += dstLen; - src += toWrite; - srcLen -= toWrite; - sawLF = 0; - } - return total; -#endif -} - -/* - *---------------------------------------------------------------------- - * - * WriteChars -- - * - * Convert UTF-8 bytes to the channel's external encoding and write the + * Convert srcLen bytes starting at src according to encoding and write * produced bytes into an output buffer, may queue the buffer for output * if it gets full, and also remembers whether the current buffer is * ready e.g. if it contains a newline and we are in line buffering mode. @@ -3901,192 +3793,6 @@ Write( return total; } - -static int -WriteChars( - Channel *chanPtr, /* The channel to buffer output for. */ - const char *src, /* UTF-8 string to write. */ - int srcLen) /* Length of UTF-8 string in bytes. */ -{ - return Write(chanPtr, src, srcLen, chanPtr->state->encoding); -} - -/* - *--------------------------------------------------------------------------- - * - * TranslateOutputEOL -- - * - * Helper function for WriteBytes() and WriteChars(). Converts the '\n' - * characters in the source buffer into the appropriate EOL form - * specified by the output translation mode. - * - * EOL translation stops either when the source buffer is empty or the - * output buffer is full. - * - * When converting to CRLF mode and there is only 1 byte left in the - * output buffer, this routine stores the '\r' in the last byte and then - * stores the '\n' in the byte just past the end of the buffer. The - * caller is responsible for passing in a buffer that is large enough to - * hold the extra byte. - * - * Results: - * The return value is 1 if a '\n' was translated from the source buffer, - * or 0 otherwise -- this can be used by the caller to decide to flush a - * line-based channel even though the channel buffer is not full. - * - * *dstLenPtr is filled with how many bytes of the output buffer were - * used. As mentioned above, this can be one more that the output - * buffer's specified length if a CRLF was stored. - * - * *srcLenPtr is filled with how many bytes of the source buffer were - * consumed. - * - * Side effects: - * It may be obvious, but bears mentioning that when converting in CRLF - * mode (which requires two bytes of storage in the output buffer), the - * number of bytes consumed from the source buffer will be less than the - * number of bytes stored in the output buffer. - * - *--------------------------------------------------------------------------- - */ - -static int -TranslateOutputEOL( - ChannelState *statePtr, /* Channel being read, for translation and - * buffering modes. */ - char *dst, /* Output buffer filled with UTF-8 chars by - * applying appropriate EOL translation to - * source characters. */ - const char *src, /* Source UTF-8 characters. */ - int *dstLenPtr, /* On entry, the maximum length of output - * buffer in bytes. On exit, the number of - * bytes actually used in output buffer. */ - int *srcLenPtr) /* On entry, the length of source buffer. On - * exit, the number of bytes read from the - * source buffer. */ -{ - char *dstEnd; - int srcLen, newlineFound; - - newlineFound = 0; - srcLen = *srcLenPtr; - - switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: - for (dstEnd = dst + srcLen; dst < dstEnd; ) { - if (*src == '\n') { - newlineFound = 1; - } - *dst++ = *src++; - } - *dstLenPtr = srcLen; - break; - case TCL_TRANSLATE_CR: - for (dstEnd = dst + srcLen; dst < dstEnd;) { - if (*src == '\n') { - *dst++ = '\r'; - newlineFound = 1; - src++; - } else { - *dst++ = *src++; - } - } - *dstLenPtr = srcLen; - break; - case TCL_TRANSLATE_CRLF: { - /* - * Since this causes the number of bytes to grow, we start off trying - * to put 'srcLen' bytes into the output buffer, but allow it to store - * more bytes, as long as there's still source bytes and room in the - * output buffer. - */ - - char *dstStart, *dstMax; - const char *srcStart; - - dstStart = dst; - dstMax = dst + *dstLenPtr; - - srcStart = src; - - if (srcLen < *dstLenPtr) { - dstEnd = dst + srcLen; - } else { - dstEnd = dst + *dstLenPtr; - } - while (dst < dstEnd) { - if (*src == '\n') { - if (dstEnd < dstMax) { - dstEnd++; - } - *dst++ = '\r'; - newlineFound = 1; - } - *dst++ = *src++; - } - *srcLenPtr = src - srcStart; - *dstLenPtr = dst - dstStart; - break; - } - default: - break; - } - return newlineFound; -} - -/* - *--------------------------------------------------------------------------- - * - * CheckFlush -- - * - * Helper function for WriteBytes() and WriteChars(). If the channel - * buffer is ready to be flushed, flush it. - * - * Results: - * The return value is -1 if there was a problem flushing the channel - * buffer, or 0 otherwise. - * - * Side effects: - * The buffer will be recycled if it is flushed. - * - *--------------------------------------------------------------------------- - */ - -static int -CheckFlush( - Channel *chanPtr, /* Channel being read, for buffering mode. */ - ChannelBuffer *bufPtr, /* Channel buffer to possibly flush. */ - int newlineFlag) /* Non-zero if a the channel buffer contains a - * newline. */ -{ - ChannelState *statePtr = chanPtr->state; - /* State info for channel */ - - /* - * The current buffer is ready for output: - * 1. if it is full. - * 2. if it contains a newline and this channel is line-buffered. - * 3. if it contains any output and this channel is unbuffered. - */ - - if ((statePtr->flags & BUFFER_READY) == 0) { - if (IsBufferFull(bufPtr)) { - SetFlag(statePtr, BUFFER_READY); - } else if (statePtr->flags & CHANNEL_LINEBUFFERED) { - if (newlineFlag != 0) { - SetFlag(statePtr, BUFFER_READY); - } - } else if (statePtr->flags & CHANNEL_UNBUFFERED) { - SetFlag(statePtr, BUFFER_READY); - } - } - if (statePtr->flags & BUFFER_READY) { - if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; - } - } - return 0; -} /* *--------------------------------------------------------------------------- -- cgit v0.12 From c00d7aa9b969d0589dffe5a2a14e6b339d8084c0 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Jan 2014 19:13:28 +0000 Subject: Trial: Implement DoWrite() as WriteBytes(). --- generic/tclIO.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index dd9f1dc..1434d88 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9213,6 +9213,9 @@ DoWrite( const char *src, /* Data to write. */ int srcLen) /* Number of bytes to write. */ { +#if 1 + return WriteBytes(chanPtr, src, srcLen); +#else ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *outBufPtr; /* Current output buffer. */ @@ -9340,6 +9343,7 @@ DoWrite( } /* Closes "while" */ return totalDestCopied; +#endif } /* -- cgit v0.12 From f11f5780e074dfe0e86e80f32d355f594e5789ad Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Jan 2014 19:30:34 +0000 Subject: Eliminate DoWrite(). It duplicates WriteBytes(). --- generic/tclIO.c | 165 +------------------------------------------------------- 1 file changed, 2 insertions(+), 163 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 1434d88..33bb98c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -189,7 +189,6 @@ static void DiscardInputQueued(ChannelState *statePtr, int discardSavedBuffers); static void DiscardOutputQueued(ChannelState *chanPtr); static int DoRead(Channel *chanPtr, char *srcPtr, int slen); -static int DoWrite(Channel *chanPtr, const char *src, int srcLen); static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead, int appendFlag); static int DoWriteChars(Channel *chan, const char *src, int len); @@ -3362,7 +3361,7 @@ Tcl_Write( if (srcLen < 0) { srcLen = strlen(src); } - return DoWrite(chanPtr, src, srcLen); + return WriteBytes(chanPtr, src, srcLen); } /* @@ -8639,7 +8638,7 @@ CopyData( } if (outBinary || sameEncoding) { - sizeb = DoWrite(outStatePtr->topChanPtr, buffer, sizeb); + sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, sizeb); } else { sizeb = DoWriteChars(outStatePtr->topChanPtr, buffer, sizeb); } @@ -9189,166 +9188,6 @@ CopyBuffer( /* *---------------------------------------------------------------------- * - * DoWrite -- - * - * Puts a sequence of characters into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. - * - * Results: - * The number of bytes written or -1 in case of error. If -1, - * Tcl_GetErrno will return the error code. - * - * Side effects: - * May buffer up output and may cause output to be produced on the - * channel. - * - *---------------------------------------------------------------------- - */ - -static int -DoWrite( - Channel *chanPtr, /* The channel to buffer output for. */ - const char *src, /* Data to write. */ - int srcLen) /* Number of bytes to write. */ -{ -#if 1 - return WriteBytes(chanPtr, src, srcLen); -#else - ChannelState *statePtr = chanPtr->state; - /* State info for channel */ - ChannelBuffer *outBufPtr; /* Current output buffer. */ - int foundNewline; /* Did we find a newline in output? */ - char *dPtr; - const char *sPtr; /* Search variables for newline. */ - int crsent; /* In CRLF eol translation mode, remember the - * fact that a CR was output to the channel - * without its following NL. */ - int i; /* Loop index for newline search. */ - int destCopied; /* How many bytes were used in this - * destination buffer to hold the output? */ - int totalDestCopied; /* How many bytes total were copied to the - * channel buffer? */ - int srcCopied; /* How many bytes were copied from the source - * string? */ - char *destPtr; /* Where in line to copy to? */ - - /* - * If we are in network (or windows) translation mode, record the fact - * that we have not yet sent a CR to the channel. - */ - - crsent = 0; - - /* - * Loop filling buffers and flushing them until all output has been - * consumed. - */ - - srcCopied = 0; - totalDestCopied = 0; - - while (srcLen > 0) { - /* - * Make sure there is a current output buffer to accept output. - */ - - if (statePtr->curOutPtr == NULL) { - statePtr->curOutPtr = AllocChannelBuffer(statePtr->bufSize); - } - - outBufPtr = statePtr->curOutPtr; - - destCopied = SpaceLeft(outBufPtr); - if (destCopied > srcLen) { - destCopied = srcLen; - } - - destPtr = InsertPoint(outBufPtr); - switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: - srcCopied = destCopied; - memcpy(destPtr, src, (size_t) destCopied); - break; - case TCL_TRANSLATE_CR: - srcCopied = destCopied; - memcpy(destPtr, src, (size_t) destCopied); - for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { - if (*dPtr == '\n') { - *dPtr = '\r'; - } - } - break; - case TCL_TRANSLATE_CRLF: - for (srcCopied = 0, dPtr = destPtr, sPtr = src; - dPtr < destPtr + destCopied; - dPtr++, sPtr++, srcCopied++) { - if (*sPtr == '\n') { - if (crsent) { - *dPtr = '\n'; - crsent = 0; - } else { - *dPtr = '\r'; - crsent = 1; - sPtr--, srcCopied--; - } - } else { - *dPtr = *sPtr; - } - } - break; - case TCL_TRANSLATE_AUTO: - Tcl_Panic("Tcl_Write: AUTO output translation mode not supported"); - default: - Tcl_Panic("Tcl_Write: unknown output translation mode"); - } - - /* - * The current buffer is ready for output if it is full, or if it - * contains a newline and this channel is line-buffered, or if it - * contains any output and this channel is unbuffered. - */ - - outBufPtr->nextAdded += destCopied; - if (!(statePtr->flags & BUFFER_READY)) { - if (IsBufferFull(outBufPtr)) { - SetFlag(statePtr, BUFFER_READY); - } else if (statePtr->flags & CHANNEL_LINEBUFFERED) { - for (sPtr = src, i = 0, foundNewline = 0; - (i < srcCopied) && (!foundNewline); - i++, sPtr++) { - if (*sPtr == '\n') { - foundNewline = 1; - break; - } - } - if (foundNewline) { - SetFlag(statePtr, BUFFER_READY); - } - } else if (statePtr->flags & CHANNEL_UNBUFFERED) { - SetFlag(statePtr, BUFFER_READY); - } - } - - totalDestCopied += srcCopied; - src += srcCopied; - srcLen -= srcCopied; - - if (statePtr->flags & BUFFER_READY) { - if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; - } - } - } /* Closes "while" */ - - return totalDestCopied; -#endif -} - -/* - *---------------------------------------------------------------------- - * * CopyEventProc -- * * This routine is invoked as a channel event handler for the background -- cgit v0.12 From 2c59046c95800977b16df9f48e11cafbdaaebe69 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Jan 2014 20:10:21 +0000 Subject: Refactor to eliminate the DoWriteChars() layer. --- generic/tclIO.c | 86 +++++++++++++++------------------------------------------ 1 file changed, 22 insertions(+), 64 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 33bb98c..542d97d 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -191,7 +191,6 @@ static void DiscardOutputQueued(ChannelState *chanPtr); static int DoRead(Channel *chanPtr, char *srcPtr, int slen); static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead, int appendFlag); -static int DoWriteChars(Channel *chan, const char *src, int len); static int FilterInputBytes(Channel *chanPtr, GetsState *statePtr); static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, @@ -3454,81 +3453,40 @@ Tcl_WriteChars( int len) /* Length of string in bytes, or < 0 for * strlen(). */ { - ChannelState *statePtr; /* State info for channel */ - - statePtr = ((Channel *) chan)->state; + Channel *chanPtr = (Channel *) chan; + ChannelState *statePtr = chanPtr->state; /* State info for channel */ + int result; + Tcl_Obj *objPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { return -1; } - return DoWriteChars((Channel *) chan, src, len); -} - -/* - *--------------------------------------------------------------------------- - * - * DoWriteChars -- - * - * Takes a sequence of UTF-8 characters and converts them for output - * using the channel's current encoding, may queue the buffer for output - * if it gets full, and also remembers whether the current buffer is - * ready e.g. if it contains a newline and we are in line buffering mode. - * Compensates stacking, i.e. will redirect the data from the specified - * channel to the topmost channel in a stack. - * - * Results: - * The number of bytes written or -1 in case of error. If -1, - * Tcl_GetErrno will return the error code. - * - * Side effects: - * May buffer up output and may cause output to be produced on the - * channel. - * - *---------------------------------------------------------------------- - */ - -static int -DoWriteChars( - Channel *chanPtr, /* The channel to buffer output for. */ - const char *src, /* UTF-8 characters to queue in output - * buffer. */ - int len) /* Length of string in bytes, or < 0 for - * strlen(). */ -{ - /* - * Always use the topmost channel of the stack - */ - - ChannelState *statePtr; /* State info for channel */ - - statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; if (len < 0) { len = strlen(src); } - if (statePtr->encoding == NULL) { - /* - * Inefficient way to convert UTF-8 to byte-array, but the code - * parallels the way it is done for objects. - * Special case for 1-byte (used by eg [puts] for the \n) could - * be extended to more efficient translation of the src string. - */ + if (statePtr->encoding) { + return WriteChars(chanPtr, src, len); + } - int result; + /* + * Inefficient way to convert UTF-8 to byte-array, but the code + * parallels the way it is done for objects. Special case for 1-byte + * (used by eg [puts] for the \n) could be extended to more efficient + * translation of the src string. + */ - if ((len == 1) && (UCHAR(*src) < 0xC0)) { - result = WriteBytes(chanPtr, src, len); - } else { - Tcl_Obj *objPtr = Tcl_NewStringObj(src, len); - src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); - result = WriteBytes(chanPtr, src, len); - TclDecrRefCount(objPtr); - } - return result; + if ((len == 1) && (UCHAR(*src) < 0xC0)) { + return WriteBytes(chanPtr, src, len); } - return WriteChars(chanPtr, src, len); + + objPtr = Tcl_NewStringObj(src, len); + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); + result = WriteBytes(chanPtr, src, len); + TclDecrRefCount(objPtr); + return result; } /* @@ -8640,7 +8598,7 @@ CopyData( if (outBinary || sameEncoding) { sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, sizeb); } else { - sizeb = DoWriteChars(outStatePtr->topChanPtr, buffer, sizeb); + sizeb = WriteChars(outStatePtr->topChanPtr, buffer, sizeb); } /* -- cgit v0.12 From b4b95b976a89e0af53c6f50373053e40a779adbd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 31 Jan 2014 09:13:13 +0000 Subject: Fix [4b3b7a3082]: tcl8.5.15/generic/tclExecute.c:7713: array index before sanity check ? --- generic/tclExecute.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e657828..2e396e8 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -73,7 +73,7 @@ int tclTraceExec = 0; * disjoint for backward-compatability reasons. */ -static const char *operatorStrings[] = { +static const char *const operatorStrings[] = { "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!", "BUILTIN FUNCTION", "FUNCTION", @@ -86,7 +86,7 @@ static const char *operatorStrings[] = { */ #ifdef TCL_COMPILE_DEBUG -static const char *resultStrings[] = { +static const char *const resultStrings[] = { "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" }; #endif @@ -7710,10 +7710,12 @@ IllegalExprOperandType( ClientData ptr; int type; unsigned char opcode = *pc; - const char *description, *operator = operatorStrings[opcode - INST_LOR]; + const char *description, *operator = "unknown"; if (opcode == INST_EXPON) { operator = "**"; + } else if (opcode <= INST_STR_NEQ) { + operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { -- cgit v0.12 From 684c2c905117d9cf20c41c5ba5bff302e82d6a36 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 31 Jan 2014 20:02:58 +0000 Subject: Do not call updateStringProc directly. We have TclGetString() for that. --- generic/tclIO.c | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 542d97d..71f8f53 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10429,17 +10429,8 @@ SetChannelFromAny( } } if (objPtr->typePtr != &tclChannelType) { - Tcl_Channel chan; + Tcl_Channel chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); - /* - * We need a valid string with which to check for a valid channel, but - * make sure not to free internal rep until validated. [Bug 1847044] - */ - if ((objPtr->typePtr != NULL) && (objPtr->bytes == NULL)) { - objPtr->typePtr->updateStringProc(objPtr); - } - - chan = Tcl_GetChannel(interp, objPtr->bytes, NULL); if (chan == NULL) { return TCL_ERROR; } -- cgit v0.12 From beb8c62dff3813dc9fbb4fc25d2ca18ffd6c6d5e Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 31 Jan 2014 20:42:21 +0000 Subject: The "channel" Tcl_ObjType is caching only. It never needs an UpdateString routine. It's also static to the tclIO.c file. --- generic/tclIO.c | 52 ++++++---------------------------------------------- 1 file changed, 6 insertions(+), 46 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 71f8f53..7705d7b 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -316,14 +316,13 @@ static int WillRead(Channel *chanPtr); static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static int SetChannelFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void UpdateStringOfChannel(Tcl_Obj *objPtr); static void FreeChannelIntRep(Tcl_Obj *objPtr); -static Tcl_ObjType tclChannelType = { +static Tcl_ObjType chanObjType = { "channel", /* name for this type */ FreeChannelIntRep, /* freeIntRepProc */ DupChannelIntRep, /* dupIntRepProc */ - NULL, /* updateStringProc UpdateStringOfChannel */ + NULL, /* updateStringProc */ NULL /* setFromAnyProc SetChannelFromAny */ }; @@ -10379,7 +10378,7 @@ DupChannelIntRep( SET_CHANNELSTATE(copyPtr, statePtr); SET_CHANNELINTERP(copyPtr, interpPtr); Tcl_Preserve((ClientData) statePtr); - copyPtr->typePtr = &tclChannelType; + copyPtr->typePtr = srcPtr->typePtr; } /* @@ -10410,7 +10409,7 @@ SetChannelFromAny( if (interp == NULL) { return TCL_ERROR; } - if (objPtr->typePtr == &tclChannelType) { + if (objPtr->typePtr == &chanObjType) { /* * The channel is valid until any call to DetachChannel occurs. * Ensure consistency checks are done. @@ -10420,15 +10419,13 @@ SetChannelFromAny( if (statePtr->flags & (CHANNEL_TAINTED|CHANNEL_CLOSED)) { ResetFlag(statePtr, CHANNEL_TAINTED); Tcl_Release((ClientData) statePtr); - UpdateStringOfChannel(objPtr); objPtr->typePtr = NULL; } else if (interpPtr != (Interp*) interp) { Tcl_Release((ClientData) statePtr); - UpdateStringOfChannel(objPtr); objPtr->typePtr = NULL; } } - if (objPtr->typePtr != &tclChannelType) { + if (objPtr->typePtr != &chanObjType) { Tcl_Channel chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); if (chan == NULL) { @@ -10440,7 +10437,7 @@ SetChannelFromAny( Tcl_Preserve((ClientData) statePtr); SET_CHANNELSTATE(objPtr, statePtr); SET_CHANNELINTERP(objPtr, interp); - objPtr->typePtr = &tclChannelType; + objPtr->typePtr = &chanObjType; } return TCL_OK; } @@ -10448,43 +10445,6 @@ SetChannelFromAny( /* *---------------------------------------------------------------------- * - * UpdateStringOfChannel -- - * - * Update the string representation for an object whose internal - * representation is "Channel". - * - * Results: - * None. - * - * Side effects: - * The object's string may be set by converting its Unicode represention - * to UTF format. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfChannel( - Tcl_Obj *objPtr) /* Object with string rep to update. */ -{ - if (objPtr->bytes == NULL) { - ChannelState *statePtr = GET_CHANNELSTATE(objPtr); - const char *name = statePtr->channelName; - if (name) { - size_t len = strlen(name); - objPtr->bytes = (char *) ckalloc(len + 1); - objPtr->length = len; - memcpy(objPtr->bytes, name, len); - } else { - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; - } - } -} - -/* - *---------------------------------------------------------------------- - * * FreeChannelIntRep -- * * Release statePtr storage. -- cgit v0.12 From e12cc95f12b130e5b9cce4c1eeef3bfc43e28676 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 31 Jan 2014 22:07:10 +0000 Subject: Simplify macro typecasting. --- generic/tclIO.c | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 7705d7b..3636861 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -331,7 +331,7 @@ static Tcl_ObjType chanObjType = { #define SET_CHANNELSTATE(objPtr, storePtr) \ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr)) #define GET_CHANNELINTERP(objPtr) \ - ((Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) + ((Tcl_Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) #define SET_CHANNELINTERP(objPtr, storePtr) \ ((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr)) @@ -10373,10 +10373,9 @@ DupChannelIntRep( * currently have an internal rep.*/ { ChannelState *statePtr = GET_CHANNELSTATE(srcPtr); - Interp *interpPtr = GET_CHANNELINTERP(srcPtr); SET_CHANNELSTATE(copyPtr, statePtr); - SET_CHANNELINTERP(copyPtr, interpPtr); + SET_CHANNELINTERP(copyPtr, GET_CHANNELINTERP(srcPtr)); Tcl_Preserve((ClientData) statePtr); copyPtr->typePtr = srcPtr->typePtr; } @@ -10404,7 +10403,6 @@ SetChannelFromAny( register Tcl_Obj *objPtr) /* The object to convert. */ { ChannelState *statePtr; - Interp *interpPtr; if (interp == NULL) { return TCL_ERROR; @@ -10415,12 +10413,11 @@ SetChannelFromAny( * Ensure consistency checks are done. */ statePtr = GET_CHANNELSTATE(objPtr); - interpPtr = GET_CHANNELINTERP(objPtr); if (statePtr->flags & (CHANNEL_TAINTED|CHANNEL_CLOSED)) { ResetFlag(statePtr, CHANNEL_TAINTED); Tcl_Release((ClientData) statePtr); objPtr->typePtr = NULL; - } else if (interpPtr != (Interp*) interp) { + } else if (interp != GET_CHANNELINTERP(objPtr)) { Tcl_Release((ClientData) statePtr); objPtr->typePtr = NULL; } -- cgit v0.12 From cca7f018e089a71b10f95e082193753b12d7ca3c Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 2 Feb 2014 14:42:12 +0000 Subject: improve the disassembly --- generic/tclCompile.c | 7 ++++++- generic/tclCompile.h | 3 ++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 08a7a4c..c5d0107 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -644,7 +644,7 @@ InstructionDesc const tclInstructionTable[] = { {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}}, /* Try converting stktop to boolean if possible. No errors. * Stack: ... value => ... value isStrictBool */ - {"strclass", 2, 0, 1, {OPERAND_UINT1}}, + {"strclass", 2, 0, 1, {OPERAND_SCLS1}}, /* See if all the characters of the given string are a member of the * specified (by opnd) character class. Note that an empty string will * satisfy the class check (standard definition of "all"). @@ -5097,6 +5097,11 @@ FormatInstruction( } 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; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 502a2e6..5665ca9 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -825,8 +825,9 @@ typedef enum InstOperandType { * variable table. */ OPERAND_LVT4, /* Four byte unsigned index into the local * variable table. */ - OPERAND_AUX4 /* Four byte unsigned index into the aux data + OPERAND_AUX4, /* Four byte unsigned index into the aux data * table. */ + OPERAND_SCLS1 /* Index into tclStringClassTable. */ } InstOperandType; typedef struct InstructionDesc { -- cgit v0.12 From f77ffeb9b26f49ef66f77929848f2ac9486f1081 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 3 Feb 2014 14:43:52 +0000 Subject: Fix [651e828a52]: Wrong Windows version reported for Windows 8.1 --- unix/tclUnixInit.c | 29 ++++++++++++++++++++++------- win/tclWinInit.c | 18 ++++++++++++++---- 2 files changed, 36 insertions(+), 11 deletions(-) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 0b98cf9..423e97e 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -33,7 +33,10 @@ #endif #ifdef __CYGWIN__ -DLLIMPORT extern __stdcall unsigned char GetVersionExA(void *); +DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *); +DLLIMPORT extern __stdcall void *LoadLibraryW(const void *); +DLLIMPORT extern __stdcall void FreeLibrary(void *); +DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *); DLLIMPORT extern __stdcall void GetSystemInfo(void *); #define NUMPLATFORMS 4 @@ -66,14 +69,14 @@ typedef struct _SYSTEM_INFO { int wProcessorRevision; } SYSTEM_INFO; -typedef struct _OSVERSIONINFOA { +typedef struct _OSVERSIONINFOW { DWORD dwOSVersionInfoSize; DWORD dwMajorVersion; DWORD dwMinorVersion; DWORD dwBuildNumber; DWORD dwPlatformId; - char szCSDVersion[128]; -} OSVERSIONINFOA; + wchar_t szCSDVersion[128]; +} OSVERSIONINFOW; #endif #ifdef HAVE_COREFOUNDATION @@ -811,7 +814,8 @@ TclpSetVariables( { #ifdef __CYGWIN__ SYSTEM_INFO sysInfo; - OSVERSIONINFOA osInfo; + static OSVERSIONINFOW osInfo; + static int osInfoInitialized = 0; char buffer[TCL_INTEGER_SPACE * 2]; #elif !defined(NO_UNAME) struct utsname name; @@ -924,8 +928,19 @@ TclpSetVariables( unameOK = 0; #ifdef __CYGWIN__ unameOK = 1; - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); - GetVersionExA(&osInfo); + if (!osInfoInitialized) { + HANDLE handle = LoadLibraryW(L"NTDLL"); + int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!getversion || getversion(&osInfo)) { + GetVersionExW(&osInfo); + } + if (handle) { + FreeLibrary(handle); + } + osInfoInitialized = 1; + } + GetSystemInfo(&sysInfo); if (osInfo.dwPlatformId < NUMPLATFORMS) { diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 81d762f..08ef1ed 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -563,7 +563,8 @@ TclpSetVariables( SYSTEM_INFO info; OemId oemId; } sys; - OSVERSIONINFOW osInfo; + static OSVERSIONINFOW osInfo; + static int osInfoInitialized = 0; Tcl_DString ds; WCHAR szUserName[UNLEN+1]; DWORD cchUserNameLen = UNLEN; @@ -571,9 +572,18 @@ TclpSetVariables( Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); - GetVersionExW(&osInfo); - + if (!osInfoInitialized) { + HANDLE handle = LoadLibraryW(L"NTDLL"); + int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!getversion || getversion(&osInfo)) { + GetVersionExW(&osInfo); + } + if (handle) { + FreeLibrary(handle); + } + osInfoInitialized = 1; + } GetSystemInfo(&sys.info); /* -- cgit v0.12 From 510244810f89a746da7291582d30cad6bb9d4232 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 4 Feb 2014 08:15:52 +0000 Subject: [971cb4f1db]: Make debugging traces less inclined to serious visual corruption --- generic/tclExecute.c | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ac78370..89305e6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5905,14 +5905,34 @@ TEBCresume( trim2 = 0; } createTrimmedString: + /* + * Careful here; trim set often contains non-ASCII characters so we + * take care when printing. [Bug 971cb4f1db] + */ + +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TRACE(("\"%.30s\" ", O2S(valuePtr))); + TclPrintObject(stdout, value2Ptr, 30); + printf(" => "); + } +#endif if (trim1 == 0 && trim2 == 0) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", - O2S(valuePtr), O2S(value2Ptr)), valuePtr); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TclPrintObject(stdout, valuePtr, 30); + printf("\n"); + } +#endif NEXT_INST_F(1, 1, 0); } else { objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TclPrintObject(stdout, objResultPtr, 30); + printf("\n"); + } +#endif NEXT_INST_F(1, 2, 1); } } -- cgit v0.12 From 5be047220df93fa607f1ccdd007b46c55ee78664 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 4 Feb 2014 09:02:23 +0000 Subject: make the printing of source much less inclined to be fazed by non-ASCII chars --- generic/tclCompile.c | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c5d0107..347e3f0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -5318,7 +5318,7 @@ PrintSourceToObj( int maxChars) /* Maximum number of chars to print. */ { register const char *p; - register int i = 0; + register int i = 0, len; if (stringPtr == NULL) { Tcl_AppendToObj(appendObj, "\"\"", -1); @@ -5327,32 +5327,50 @@ PrintSourceToObj( Tcl_AppendToObj(appendObj, "\"", -1); p = stringPtr; - for (; (*p != '\0') && (i < maxChars); p++, i++) { - switch (*p) { + 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: - Tcl_AppendPrintfToObj(appendObj, "%c", *p); + 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 -- cgit v0.12 From f53e4a7a0e3c71fa19e6909a733d7e1ba50190cc Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 4 Feb 2014 14:30:55 +0000 Subject: Be sure to finalize the identity encoding. --- generic/tclEncoding.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index c303dd1..1842fb6 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -658,6 +658,7 @@ TclFinalizeEncodingSubsystem(void) Tcl_MutexLock(&encodingMutex); encodingsInitialized = 0; FreeEncoding(systemEncoding); + FreeEncoding(tclIdentityEncoding); hPtr = Tcl_FirstHashEntry(&encodingTable, &search); while (hPtr != NULL) { -- cgit v0.12 From 876dd3ac964025a81a9dc07a1006242bb4fc7256 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Feb 2014 21:21:53 +0000 Subject: Add missing __stdcall (which crashes on win32), and clean-up indenting --- unix/tclUnixInit.c | 22 ++++++++++++---------- win/tclWinInit.c | 21 +++++++++++---------- 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 423e97e..11a65707 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -38,6 +38,7 @@ DLLIMPORT extern __stdcall void *LoadLibraryW(const void *); DLLIMPORT extern __stdcall void FreeLibrary(void *); DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *); DLLIMPORT extern __stdcall void GetSystemInfo(void *); +DLLIMPORT extern __stdcall void GetSystemInfo(void *); #define NUMPLATFORMS 4 static const char *const platforms[NUMPLATFORMS] = { @@ -929,16 +930,17 @@ TclpSetVariables( #ifdef __CYGWIN__ unameOK = 1; if (!osInfoInitialized) { - HANDLE handle = LoadLibraryW(L"NTDLL"); - int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); - if (!getversion || getversion(&osInfo)) { - GetVersionExW(&osInfo); - } - if (handle) { - FreeLibrary(handle); - } - osInfoInitialized = 1; + HANDLE handle = LoadLibraryW(L"NTDLL"); + __stdcall int(*getversion)(void *) = + (__stdcall int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!getversion || getversion(&osInfo)) { + GetVersionExW(&osInfo); + } + if (handle) { + FreeLibrary(handle); + } + osInfoInitialized = 1; } GetSystemInfo(&sysInfo); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 08ef1ed..f49edf0 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -573,16 +573,17 @@ TclpSetVariables( TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); if (!osInfoInitialized) { - HANDLE handle = LoadLibraryW(L"NTDLL"); - int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); - if (!getversion || getversion(&osInfo)) { - GetVersionExW(&osInfo); - } - if (handle) { - FreeLibrary(handle); - } - osInfoInitialized = 1; + HANDLE handle = LoadLibraryW(L"NTDLL"); + __stdcall int(*getversion)(void *) = + (__stdcall int(*)(void *)) GetProcAddress(handle, "RtlGetVersion"); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!getversion || getversion(&osInfo)) { + GetVersionExW(&osInfo); + } + if (handle) { + FreeLibrary(handle); + } + osInfoInitialized = 1; } GetSystemInfo(&sys.info); -- cgit v0.12 From fc5e6debdee34caf68237de6750c1bb4c230e2bc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Feb 2014 21:29:44 +0000 Subject: remove duplicate declaration --- unix/tclUnixInit.c | 1 - 1 file changed, 1 deletion(-) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 11a65707..7e0b19a 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -38,7 +38,6 @@ DLLIMPORT extern __stdcall void *LoadLibraryW(const void *); DLLIMPORT extern __stdcall void FreeLibrary(void *); DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *); DLLIMPORT extern __stdcall void GetSystemInfo(void *); -DLLIMPORT extern __stdcall void GetSystemInfo(void *); #define NUMPLATFORMS 4 static const char *const platforms[NUMPLATFORMS] = { -- cgit v0.12 From c7569e1c35930b65d7242445d29707703efbe040 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Feb 2014 21:51:32 +0000 Subject: Satisfy required position of __stdcall from VC++ --- unix/tclUnixInit.c | 4 ++-- win/tclWinInit.c | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 7e0b19a..a8cd00d 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -930,8 +930,8 @@ TclpSetVariables( unameOK = 1; if (!osInfoInitialized) { HANDLE handle = LoadLibraryW(L"NTDLL"); - __stdcall int(*getversion)(void *) = - (__stdcall int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); + int(__stdcall *getversion)(void *) = + (int(__stdcall *)(void *))GetProcAddress(handle, "RtlGetVersion"); osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); if (!getversion || getversion(&osInfo)) { GetVersionExW(&osInfo); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index f49edf0..2f3c7e8 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -574,8 +574,8 @@ TclpSetVariables( if (!osInfoInitialized) { HANDLE handle = LoadLibraryW(L"NTDLL"); - __stdcall int(*getversion)(void *) = - (__stdcall int(*)(void *)) GetProcAddress(handle, "RtlGetVersion"); + int(__stdcall *getversion)(void *) = + (int(__stdcall *)(void *)) GetProcAddress(handle, "RtlGetVersion"); osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); if (!getversion || getversion(&osInfo)) { GetVersionExW(&osInfo); -- cgit v0.12 From cacb7964419f0a9e675e9d448dbf00ebcd951eb2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 Feb 2014 21:44:43 +0000 Subject: Check for existance of __BORLANDC__ before using its value --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index 31960ec..5300bba 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -168,7 +168,7 @@ extern "C" { * MSVCRT. */ -#if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) +#if (defined(__WIN32__) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) # define HAVE_DECLSPEC 1 # ifdef STATIC_BUILD # define DLLIMPORT -- cgit v0.12 From 438b687249f8f901a7d0e17608a7f2b506f1e5d6 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Feb 2014 22:38:17 +0000 Subject: [a4494e28ed] Use flag bit instead of NULL pointer to suppress teardown list of imported commands when the original command gets re-created. This prevents the panic otherwise possible when the invalid state represented by the NULL pointer is encountered during a command delete trace. --- generic/tclBasic.c | 39 +++++++++++++++++++++++++++++---------- generic/tclInt.h | 1 + tests/namespace.test | 9 +++++++++ 3 files changed, 39 insertions(+), 10 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c3ab871..89d6b8f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1887,10 +1887,19 @@ Tcl_CreateCommand( */ cmdPtr = Tcl_GetHashValue(hPtr); - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + } + TclCleanupCommandMacro(cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); if (!isNew) { /* @@ -2061,10 +2070,19 @@ Tcl_CreateObjCommand( * intact. */ - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + } + TclCleanupCommandMacro(cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); if (!isNew) { /* @@ -2869,12 +2887,13 @@ Tcl_DeleteCommandFromToken( * commands were created that refer back to this command. Delete these * imported commands now. */ - - for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; - refPtr = nextRefPtr) { - nextRefPtr = refPtr->nextPtr; - importCmd = (Tcl_Command) refPtr->importedCmdPtr; - Tcl_DeleteCommandFromToken(interp, importCmd); + if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) { + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + refPtr = nextRefPtr) { + nextRefPtr = refPtr->nextPtr; + importCmd = (Tcl_Command) refPtr->importedCmdPtr; + Tcl_DeleteCommandFromToken(interp, importCmd); + } } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index b45f8e3..f869ff0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1528,6 +1528,7 @@ typedef struct Command { #define CMD_IS_DELETED 0x1 #define CMD_TRACE_ACTIVE 0x2 #define CMD_HAS_EXEC_TRACES 0x4 +#define CMD_REDEF_IN_PROGRESS 0x8 /* *---------------------------------------------------------------- diff --git a/tests/namespace.test b/tests/namespace.test index 4eecac1..b59e09e 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -556,6 +556,15 @@ test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { lappend l [info commands ::test_ns_import::*] } } {::test_ns_import::cmd1 {}} +test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { + # Will panic if still buggy + namespace eval src {namespace export foo; proc foo {} {}} + namespace eval dst {namespace import [namespace parent]::src::foo} + trace add command src::foo delete \ + "[list namespace delete [namespace current]::dst] ;#" + proc src::foo {} {} + namespace delete src +} {} test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { catch {namespace delete {*}[namespace children :: test_ns_*]} -- cgit v0.12 From 5ff110b484ef081f2bc5c6b8cbf1d234beaa489d Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Feb 2014 22:41:14 +0000 Subject: Change the flag value to avoid merge conflict with trunk. --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index f869ff0..1348340 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1528,7 +1528,7 @@ typedef struct Command { #define CMD_IS_DELETED 0x1 #define CMD_TRACE_ACTIVE 0x2 #define CMD_HAS_EXEC_TRACES 0x4 -#define CMD_REDEF_IN_PROGRESS 0x8 +#define CMD_REDEF_IN_PROGRESS 0x10 /* *---------------------------------------------------------------- -- cgit v0.12 From 0258413bde6ef149dba024baac68f1fc66170293 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Feb 2014 11:59:22 +0000 Subject: Eliminate all usage of WIN32 and __WIN32__ macros: Some compilers (e.g. Clang/LLVM) don't define it, and _WIN32 is much more portable anyway. See: [http://nadeausoftware.com/articles/2012/01/c_c_tip_how_use_compiler_predefined_macros_detect_operating_system#WindowsCygwinnonPOSIXandMinGW] --- generic/tcl.h | 35 ++++++++++++++++------------------- generic/tclClock.c | 2 +- generic/tclCmdAH.c | 2 +- generic/tclDecls.h | 24 ++++++++++++------------ generic/tclEnv.c | 4 ++-- generic/tclFCmd.c | 2 +- generic/tclIOUtil.c | 8 ++++---- generic/tclIntDecls.h | 0 generic/tclIntPlatDecls.h | 16 ++++++++-------- generic/tclLoad.c | 4 ++-- generic/tclMain.c | 2 +- generic/tclPathObj.c | 6 +++--- generic/tclPlatDecls.h | 6 +++--- generic/tclStubInit.c | 20 ++++++++++---------- generic/tclTest.c | 6 +++--- generic/tclThreadJoin.c | 4 ++-- tools/genStubs.tcl | 6 +++--- win/configure | 4 ++-- win/tcl.m4 | 4 ++-- win/tclWin32Dll.c | 4 ++-- win/tclWinTest.c | 2 +- 21 files changed, 79 insertions(+), 82 deletions(-) mode change 100644 => 100755 generic/tclDecls.h mode change 100644 => 100755 generic/tclIntDecls.h mode change 100644 => 100755 generic/tclIntPlatDecls.h mode change 100644 => 100755 generic/tclPlatDecls.h mode change 100644 => 100755 generic/tclStubInit.c diff --git a/generic/tcl.h b/generic/tcl.h index b7237bf..b93b3ac 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -67,15 +67,12 @@ extern "C" { * We use this method because there is no autoconf equivalent. */ -#ifndef __WIN32__ -# if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__)) +#ifdef _WIN32 +# ifndef __WIN32__ # define __WIN32__ -# ifndef WIN32 -# define WIN32 -# endif -# ifndef _WIN32 -# define _WIN32 -# endif +# endif +# ifndef WIN32 +# define WIN32 # endif #endif @@ -83,11 +80,11 @@ extern "C" { * STRICT: See MSDN Article Q83456 */ -#ifdef __WIN32__ +#ifdef _WIN32 # ifndef STRICT # define STRICT # endif -#endif /* __WIN32__ */ +#endif /* _WIN32 */ /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double @@ -191,7 +188,7 @@ extern "C" { * MSVCRT. */ -#if (defined(__WIN32__) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) +#if (defined(_WIN32) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) # define HAVE_DECLSPEC 1 # ifdef STATIC_BUILD # define DLLIMPORT @@ -315,14 +312,14 @@ extern "C" { * VOID. This block is skipped under Cygwin and Mingw. */ -#if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID) +#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID) #ifndef VOID #define VOID void typedef char CHAR; typedef short SHORT; typedef long LONG; #endif -#endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */ +#endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */ /* * Macro to use instead of "void" for arguments that must have type "void *" @@ -390,7 +387,7 @@ typedef long LONG; */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(__WIN32__) +# if defined(_WIN32) # define TCL_WIDE_INT_TYPE __int64 # ifdef __BORLANDC__ # define TCL_LL_MODIFIER "L" @@ -400,7 +397,7 @@ typedef long LONG; # elif defined(__GNUC__) # define TCL_WIDE_INT_TYPE long long # define TCL_LL_MODIFIER "ll" -# else /* ! __WIN32__ && ! __GNUC__ */ +# else /* ! _WIN32 && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... @@ -415,7 +412,7 @@ typedef long LONG; # define TCL_WIDE_INT_TYPE long long # endif # endif /* NO_LIMITS_H */ -# endif /* __WIN32__ */ +# endif /* _WIN32 */ #endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ #ifdef TCL_WIDE_INT_IS_LONG # undef TCL_WIDE_INT_TYPE @@ -447,7 +444,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; # define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #endif /* TCL_WIDE_INT_IS_LONG */ -#if defined(__WIN32__) +#if defined(_WIN32) # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; # elif defined(_WIN64) @@ -562,7 +559,7 @@ typedef struct Tcl_ZLibStream_ *Tcl_ZlibStream; * will be called as the main fuction of the new thread created by that call. */ -#if defined __WIN32__ +#if defined _WIN32 typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData); #else typedef void (Tcl_ThreadCreateProc) (ClientData clientData); @@ -574,7 +571,7 @@ typedef void (Tcl_ThreadCreateProc) (ClientData clientData); * in generic/tclThreadTest.c for it's usage. */ -#if defined __WIN32__ +#if defined _WIN32 # define Tcl_ThreadCreateType unsigned __stdcall # define TCL_THREAD_CREATE_RETURN return 0 #else diff --git a/generic/tclClock.c b/generic/tclClock.c index 6d2976d..50d480c 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -19,7 +19,7 @@ * Windows has mktime. The configurators do not check. */ -#ifdef __WIN32__ +#ifdef _WIN32 #define HAVE_MKTIME 1 #endif diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f90819a..d90a747 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1590,7 +1590,7 @@ FileAttrIsOwnedCmd( * test for equivalence to the current user. */ -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) value = 1; #else value = (geteuid() == buf.st_uid); diff --git a/generic/tclDecls.h b/generic/tclDecls.h old mode 100644 new mode 100755 index 830c998..91c0add --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -63,7 +63,7 @@ EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line); /* 8 */ EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size, const char *file, int line); -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); @@ -73,7 +73,7 @@ EXTERN void Tcl_CreateFileHandler(int fd, int mask, EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 10 */ EXTERN void Tcl_DeleteFileHandler(int fd); #endif /* UNIX */ @@ -511,7 +511,7 @@ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, @@ -1835,19 +1835,19 @@ typedef struct TclStubs { char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */ void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */ char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved9)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved10)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -2009,10 +2009,10 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved167)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -2513,7 +2513,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DbCkfree) /* 7 */ #define Tcl_DbCkrealloc \ (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif /* UNIX */ @@ -2521,7 +2521,7 @@ extern const TclStubs *tclStubsPtr; #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_DeleteFileHandler \ (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ #endif /* UNIX */ @@ -2841,7 +2841,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif /* UNIX */ diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 8f51c1b..cd1a954 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -444,7 +444,7 @@ TclUnsetEnv( * that no = should be included, and Windows requires it. */ -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) string = ckalloc(length + 2); memcpy(string, name, (size_t) length); string[length] = '='; @@ -453,7 +453,7 @@ TclUnsetEnv( string = ckalloc(length + 1); memcpy(string, name, (size_t) length); string[length] = '\0'; -#endif /* WIN32 */ +#endif /* _WIN32 */ Tcl_UtfToExternalDString(NULL, string, -1, &envString); string = ckrealloc(string, Tcl_DStringLength(&envString) + 1); diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 13377d3..6452fff 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -517,7 +517,7 @@ CopyRenameOneFile( * 16 bits and we get collisions. See bug #2015723. */ -#if !defined(WIN32) && !defined(__CYGWIN__) +#if !defined(_WIN32) && !defined(__CYGWIN__) if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6259216..f624cb7 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -19,7 +19,7 @@ */ #include "tclInt.h" -#ifdef __WIN32__ +#ifdef _WIN32 # include "tclWinInt.h" #endif #include "tclFileSystem.h" @@ -792,7 +792,7 @@ TclFinalizeFilesystem(void) * filesystem is likely to fail. */ -#ifdef __WIN32__ +#ifdef _WIN32 TclWinEncodingsCleanup(); #endif } @@ -819,7 +819,7 @@ TclResetFilesystem(void) filesystemList = &nativeFilesystemRecord; theFilesystemEpoch++; -#ifdef __WIN32__ +#ifdef _WIN32 /* * Cleans up the win32 API filesystem proc lookup table. This must happen * very late in finalization so that deleting of copied dlls can occur. @@ -3255,7 +3255,7 @@ Tcl_LoadFile( return TCL_ERROR; } -#ifndef __WIN32__ +#ifndef _WIN32 /* * Do we need to set appropriate permissions on the file? This may be * required on some systems. On Unix we could loop over the file diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h old mode 100644 new mode 100755 diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h old mode 100644 new mode 100755 index 72719fe..2c74b5a --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -13,7 +13,7 @@ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS -#ifdef __WIN32__ +#ifdef _WIN32 # define Tcl_DirEntry void # define DIR void #endif @@ -45,7 +45,7 @@ extern "C" { * Exported function declarations: */ -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -104,7 +104,7 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN void TclWinConvertError(DWORD errCode); /* 1 */ @@ -258,7 +258,7 @@ typedef struct TclIntPlatStubs { int magic; void *hooks; -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ @@ -291,7 +291,7 @@ typedef struct TclIntPlatStubs { int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ void (*tclWinConvertError) (DWORD errCode); /* 0 */ void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */ struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ @@ -371,7 +371,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; * Inline function declarations: */ -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #define TclpCloseFile \ @@ -420,7 +420,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclWinConvertWSAError \ @@ -550,7 +550,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) # undef TclWinNToHS # define TclWinNToHS ntohs #else diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 5cacab1..7c70e03 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -830,7 +830,7 @@ Tcl_UnloadObjCmd( * Unload the shared library from the application memory... */ -#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) +#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* * Some Unix dlls are poorly behaved - registering things like atexit * calls that can't be unregistered. If you unload such dlls, you get @@ -1151,7 +1151,7 @@ TclFinalizeLoad(void) pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; -#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) +#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* * Some Unix dlls are poorly behaved - registering things like atexit * calls that can't be unregistered. If you unload such dlls, you get diff --git a/generic/tclMain.c b/generic/tclMain.c index faea75a..360f5e9 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -47,7 +47,7 @@ * we have to translate that to strcmp here. */ -#ifndef __WIN32__ +#ifndef _WIN32 # define TCHAR char # define TEXT(arg) arg # define _tcscmp strcmp diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index b7f3dcf..fe6063f 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -512,7 +512,7 @@ TclFSGetPathType( if (PATHFLAGS(pathPtr) == 0) { /* The path is not absolute... */ -#ifdef __WIN32__ +#ifdef _WIN32 /* ... on Windows we must make another call to determine whether * it's relative or volumerelative [Bug 2571597]. */ return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, @@ -1956,7 +1956,7 @@ Tcl_FSGetNormalizedPath( /* * We have a refCount on the cwd. */ -#ifdef __WIN32__ +#ifdef _WIN32 } else if (type == TCL_PATH_VOLUME_RELATIVE) { /* * Only Windows has volume-relative paths. @@ -1969,7 +1969,7 @@ Tcl_FSGetNormalizedPath( return NULL; } pureNormalized = 0; -#endif /* __WIN32__ */ +#endif /* _WIN32 */ } } diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h old mode 100644 new mode 100755 index 681854d..abc8ee8 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -50,7 +50,7 @@ extern "C" { * Exported function declarations: */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr); @@ -75,7 +75,7 @@ typedef struct TclPlatStubs { int magic; void *hooks; -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ #endif /* WIN */ @@ -97,7 +97,7 @@ extern const TclPlatStubs *tclPlatStubsPtr; * Inline function declarations: */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define Tcl_WinUtfToTChar \ (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ #define Tcl_WinTCharToUtf \ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c old mode 100644 new mode 100755 index e1918ef..097269f --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -90,7 +90,7 @@ static unsigned short TclWinNToHS(unsigned short ns) { } #endif -#ifdef __WIN32__ +#ifdef _WIN32 # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 @@ -557,7 +557,7 @@ static const TclIntStubs tclIntStubs = { static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ TclGetAndDetachPids, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ @@ -590,7 +590,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ TclWinConvertWSAError, /* 1 */ TclWinGetServByName, /* 2 */ @@ -661,7 +661,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ #endif /* WIN */ @@ -758,19 +758,19 @@ const TclStubs tclStubs = { Tcl_DbCkalloc, /* 6 */ Tcl_DbCkfree, /* 7 */ Tcl_DbCkrealloc, /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_CreateFileHandler, /* 9 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 9 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_CreateFileHandler, /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_DeleteFileHandler, /* 10 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 10 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -932,10 +932,10 @@ const TclStubs tclStubs = { Tcl_GetMaster, /* 164 */ Tcl_GetNameOfExecutable, /* 165 */ Tcl_GetObjResult, /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_GetOpenFile, /* 167 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 167 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ diff --git a/generic/tclTest.c b/generic/tclTest.c index f121d0d..a27c95a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -414,7 +414,7 @@ static int TestNRELevels(ClientData clientData, static int TestInterpResolverCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) static int TestcpuidCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); @@ -681,7 +681,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, NULL, NULL); -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, (ClientData) 0, NULL); #endif @@ -6648,7 +6648,7 @@ TestNumUtfCharsCmd( return TCL_OK; } -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- * diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c index 4b09e1c..5c70a62 100644 --- a/generic/tclThreadJoin.c +++ b/generic/tclThreadJoin.c @@ -14,7 +14,7 @@ #include "tclInt.h" -#ifdef WIN32 +#ifdef _WIN32 /* * The information about each joinable thread is remembered in a structure as @@ -305,7 +305,7 @@ TclSignalExitThread( Tcl_MutexUnlock(&threadPtr->threadMutex); } -#endif /* WIN32 */ +#endif /* _WIN32 */ /* * Local Variables: diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index b45e560..7a75dc6 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -283,7 +283,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { set text "" switch $plat { win { - append text "#if defined(__WIN32__)" + append text "#if defined(_WIN32)" if {$withCygwin} { append text " || defined(__CYGWIN__)" } @@ -294,7 +294,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { append text "#endif /* WIN */\n" } unix { - append text "#if !defined(__WIN32__)" + append text "#if !defined(_WIN32)" if {$withCygwin} { append text " && !defined(__CYGWIN__)" } @@ -320,7 +320,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { append text "#endif /* AQUA */\n" } x11 { - append text "#if !(defined(__WIN32__)" + append text "#if !(defined(_WIN32)" if {$withCygwin} { append text " || defined(__CYGWIN__)" } diff --git a/win/configure b/win/configure index 569172e..2affd38 100755 --- a/win/configure +++ b/win/configure @@ -3340,7 +3340,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifndef __WIN32__ + #ifndef _WIN32 #error cross-compiler #endif @@ -3463,7 +3463,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifdef __WIN32__ + #ifdef _WIN32 #error win32 #endif diff --git a/win/tcl.m4 b/win/tcl.m4 index 625c329..d12ae10 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -572,7 +572,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for cross-compile version of gcc, ac_cv_cross, AC_TRY_COMPILE([ - #ifndef __WIN32__ + #ifndef _WIN32 #error cross-compiler #endif ], [], @@ -639,7 +639,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ - #ifdef __WIN32__ + #ifdef _WIN32 #error win32 #endif ], [], diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 634e1d2..688fa8d 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -69,7 +69,7 @@ TCL_DECLARE_MUTEX(mountPointMap) * We will need this below. */ -#ifdef __WIN32__ +#ifdef _WIN32 #ifndef STATIC_BUILD /* @@ -137,7 +137,7 @@ DllMain( return TRUE; } #endif /* !STATIC_BUILD */ -#endif /* __WIN32__ */ +#endif /* _WIN32 */ /* *---------------------------------------------------------------------- diff --git a/win/tclWinTest.c b/win/tclWinTest.c index b83c0ba..6027e32 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -17,7 +17,7 @@ /* * For TestplatformChmod on Windows */ -#ifdef __WIN32__ +#ifdef _WIN32 #include #endif -- cgit v0.12 From 89583a6623c604081575a6bc1262024c05f5f8ae Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 11 Feb 2014 08:53:33 +0000 Subject: Changed position of flag evaluation as proposed by Phil Hoffman --- win/tclWinChan.c | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 19e3655..6d480a8 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -886,24 +886,6 @@ TclpOpenFileChannel( } /* - * If the file is being created, get the file attributes from the - * permissions argument, else use the existing file attributes. - */ - - if (mode & O_CREAT) { - if (permissions & S_IWRITE) { - flags = FILE_ATTRIBUTE_NORMAL; - } else { - flags = FILE_ATTRIBUTE_READONLY; - } - } else { - flags = (*tclWinProcs->getFileAttributesProc)(nativeName); - if (flags == 0xFFFFFFFF) { - flags = 0; - } - } - - /* * [2413550] Avoid double-open of serial ports on Windows * Special handling for Windows serial ports by a "name-hint" * to directly open it with the OVERLAPPED flag set. @@ -931,6 +913,24 @@ TclpOpenFileChannel( return channel; } /* + * If the file is being created, get the file attributes from the + * permissions argument, else use the existing file attributes. + */ + + if (mode & O_CREAT) { + if (permissions & S_IWRITE) { + flags = FILE_ATTRIBUTE_NORMAL; + } else { + flags = FILE_ATTRIBUTE_READONLY; + } + } else { + flags = (*tclWinProcs->getFileAttributesProc)(nativeName); + if (flags == 0xFFFFFFFF) { + flags = 0; + } + } + + /* * Set up the file sharing mode. We want to allow simultaneous access. */ -- cgit v0.12 From f0882154a86285513226fa828f8a846025523cf1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Feb 2014 10:58:30 +0000 Subject: Fix execute permission bit (should not be set) for *Decls.h files --- generic/tclDecls.h | 0 generic/tclIntDecls.h | 0 generic/tclIntPlatDecls.h | 0 generic/tclPlatDecls.h | 0 generic/tclStubInit.c | 0 5 files changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 generic/tclDecls.h mode change 100755 => 100644 generic/tclIntDecls.h mode change 100755 => 100644 generic/tclIntPlatDecls.h mode change 100755 => 100644 generic/tclPlatDecls.h mode change 100755 => 100644 generic/tclStubInit.c diff --git a/generic/tclDecls.h b/generic/tclDecls.h old mode 100755 new mode 100644 diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h old mode 100755 new mode 100644 diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h old mode 100755 new mode 100644 diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h old mode 100755 new mode 100644 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c old mode 100755 new mode 100644 -- cgit v0.12 From 78bbf020ea1c7fcd328481e037cee92e3fcbd6fa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Feb 2014 12:13:32 +0000 Subject: typo --- unix/tclConfig.sh.in | 2 +- win/tclConfig.sh.in | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/tclConfig.sh.in b/unix/tclConfig.sh.in index d47e686..b58e9fd 100644 --- a/unix/tclConfig.sh.in +++ b/unix/tclConfig.sh.in @@ -165,5 +165,5 @@ TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' -# Flag, 1: we built Tcl with threads enables, 0 we didn't +# Flag, 1: we built Tcl with threads enabled, 0 we didn't TCL_THREADS=@TCL_THREADS@ diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in index 65bc5c5..00a8790 100644 --- a/win/tclConfig.sh.in +++ b/win/tclConfig.sh.in @@ -175,6 +175,6 @@ TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' -# Flag, 1: we built Tcl with threads enables, 0 we didn't +# Flag, 1: we built Tcl with threads enabled, 0 we didn't TCL_THREADS=@TCL_THREADS@ -- cgit v0.12 From c91f173c8b1d3db987da4db9516320af5771bf3a Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 16 Feb 2014 08:18:29 +0000 Subject: [9bf7e67b37]: minor documentation blooper --- doc/tclvars.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/tclvars.n b/doc/tclvars.n index 2fec222..9d7a4ce 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -10,7 +10,7 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceEval, tcl_wordchars, tcl_version \- Variables used by Tcl +argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl .BE .SH DESCRIPTION .PP -- cgit v0.12 From fa1ab4f7406c54a825d0a91a5af095804b334fa8 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 19 Feb 2014 14:10:55 +0000 Subject: [1230597] Update test comment. --- tests/namespace.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/namespace.test b/tests/namespace.test index b59e09e..71b6860 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -301,7 +301,7 @@ test namespace-9.4 {Tcl_Import, simple import} { } test_ns_import::p } {cmd1: 123} -test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} { +test namespace-9.5 {Tcl_Import, RFE 1230597} { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg } {0 {}} test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { -- cgit v0.12 From 1a8dc819d6bcc0e11cfb42723b9a529943b7f63b Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 23 Feb 2014 13:07:36 +0000 Subject: [3597178]: Improve documentation of what's going on with encodings --- doc/encoding.n | 34 +++++++++++++++++++++++++++------- doc/string.n | 28 ++++++++++++++++++++++++---- 2 files changed, 51 insertions(+), 11 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index be1dc3f..5782199 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -14,10 +14,21 @@ encoding \- Manipulate encodings .BE .SH INTRODUCTION .PP -Strings in Tcl are encoded using 16-bit Unicode characters. Different -operating system interfaces or applications may generate strings in -other encodings such as Shift-JIS. The \fBencoding\fR command helps -to bridge the gap between Unicode and these other formats. +Strings in Tcl are logically a sequence of 16-bit Unicode characters. +These strings are represented in memory as a sequence of bytes that +may be in one of several encodings: modified UTF\-8 (which uses 1 to 3 +bytes per character), 16-bit +.QW Unicode +(which uses 2 bytes per character, with an endianness that is +dependent on the host architecture), and binary (which uses a single +byte per character but only handles a restricted range of characters). +Tcl does not guarantee to always use the same encoding for the same +string. +.PP +Different operating system interfaces or applications may generate +strings in other encodings such as Shift\-JIS. The \fBencoding\fR +command helps to bridge the gap between Unicode and these other +formats. .SH DESCRIPTION .PP Performs one of several encoding related operations, depending on @@ -37,8 +48,9 @@ system encoding is used. Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted string. Each byte is stored in the lower 8-bits of a Unicode -character. If \fIencoding\fR is not specified, the current -system encoding is used. +character (indeed, the resulting string is a binary string as far as +Tcl is concerned, at least initially). If \fIencoding\fR is not +specified, the current system encoding is used. .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? . @@ -56,6 +68,11 @@ searchable directory, that element is ignored. . Returns a list containing the names of all of the encodings that are currently available. +The encodings +.QW utf-8 +and +.QW iso8859-1 +are guaranteed to be present in the list. .TP \fBencoding system\fR ?\fIencoding\fR? . @@ -73,7 +90,7 @@ However, because the \fBsource\fR command always reads files using the current system encoding, Tcl will only source such files correctly when the encoding used to write the file is the same. This tends not to be true in an internationalized setting. For example, if such a -file was sourced in North America (where the ISO8859-1 is normally +file was sourced in North America (where the ISO8859\-1 is normally used), each byte in the file would be treated as a separate character that maps to the 00 page in Unicode. The resulting Tcl strings will not contain the expected Japanese characters. Instead, they will @@ -93,3 +110,6 @@ which is the Hiragana letter HA. Tcl_GetEncoding(3) .SH KEYWORDS encoding, unicode +.\" Local Variables: +.\" mode: nroff +.\" End: diff --git a/doc/string.n b/doc/string.n index 76005fc..163abdd 100644 --- a/doc/string.n +++ b/doc/string.n @@ -343,10 +343,13 @@ misleading. \fBstring bytelength \fIstring\fR . Returns a decimal string giving the number of bytes used to represent -\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to -represent Unicode characters, the byte length will not be the same as -the character length in general. The cases where a script cares about -the byte length are rare. +\fIstring\fR in memory when encoded as Tcl's internal modified UTF\-8; +Tcl may use other encodings for \fIstring\fR as well, and does not +guarantee to only use a single encoding for a particular \fIstring\fR. +Because UTF\-8 uses a variable number of bytes to represent Unicode +characters, the byte length will not be the same as the character +length in general. The cases where a script cares about the byte +length are rare. .RS .PP In almost all cases, you should use the @@ -354,10 +357,27 @@ In almost all cases, you should use the Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual entry for more details on the UTF\-8 representation. .PP +Formally, the \fBstring bytelength\fR operation returns the content of +the \fIlength\fR field of the \fBTcl_Obj\fR structure, after calling +\fBTcl_GetString\fR to ensure that the \fIbytes\fR field is populated. +This is highly unlikely to be useful to Tcl scripts, as Tcl's internal +encoding is not strict UTF\-8, but rather a modified CESU\-8 with a +denormalized NUL (identical to that used in a number of places by +Java's serialization mechanism) to enable basic processing with +non-Unicode-aware C functions. As this representation should only +ever be used by Tcl's implementation, the number of bytes used to +store the representation is of very low value (except to C extension +code, which has direct access for the purpose of memory management, +etc.) +.PP \fICompatibility note:\fR it is likely that this subcommand will be withdrawn in a future version of Tcl. It is better to use the \fBencoding convertto\fR command to convert a string to a known encoding and then apply \fBstring length\fR to that. +.PP +.CS +\fBstring length\fR [encoding convertto utf-8 $theString] +.CE .RE .TP \fBstring wordend \fIstring charIndex\fR -- cgit v0.12 From 282de06cab689f8baa856923a62e4ad99167e57c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Feb 2014 15:49:52 +0000 Subject: [8d5f5b8034] Flush internal representations in [string tolower] of unshared obj --- generic/tclExecute.c | 3 +++ tests/string.test | 9 +++++++++ 2 files changed, 12 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 89305e6..41730d3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5392,6 +5392,7 @@ TEBCresume( } else { length = Tcl_UtfToUpper(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5408,6 +5409,7 @@ TEBCresume( } else { length = Tcl_UtfToLower(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5424,6 +5426,7 @@ TEBCresume( } else { length = Tcl_UtfToTitle(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } diff --git a/tests/string.test b/tests/string.test index 740cdc6..cf658a2 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1398,6 +1398,9 @@ test string-15.9 {string tolower} { test string-15.10 {string tolower, unicode} { string tolower ABCabc\xc7\xe7 } "abcabc\xe7\xe7" +test string-15.11 {string tolower, compiled} { + lindex [string tolower [list A B [list C]]] 1 +} b test string-16.1 {string toupper} { list [catch {string toupper} msg] $msg @@ -1429,6 +1432,9 @@ test string-16.9 {string toupper} { test string-16.10 {string toupper, unicode} { string toupper ABCabc\xc7\xe7 } "ABCABC\xc7\xc7" +test string-16.11 {string toupper, compiled} { + lindex [string toupper [list a b [list c]]] 1 +} B test string-17.1 {string totitle} { list [catch {string totitle} msg] $msg @@ -1451,6 +1457,9 @@ test string-17.6 {string totitle, unicode} { test string-17.7 {string totitle, unicode} { string totitle \u01f3BCabc\xc7\xe7 } "\u01f2bcabc\xe7\xe7" +test string-17.8 {string totitle, compiled} { + lindex [string totitle [list aa bb [list cc]]] 0 +} Aa test string-18.1 {string trim} { list [catch {string trim} msg] $msg -- cgit v0.12