From 8324cc91dbdb33bfd5799067e96c62769b8fb9c9 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 72901fb88ca266a88a78b0a34c4db3b3c386e367 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 eaaed023dfb41a1d60c320fccf77c54204c4143e 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 2bcd186571b8f37c820add859b48f7046260d261 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Apr 2013 18:11:33 +0000 Subject: Revise TclNREvalObjv so that pre-resolution of the Command by a caller does not force suppression of exception handling. Let those be separable demands. Aim is to bring TclObjInvoke*() into the fold. --- generic/tclBasic.c | 17 ++++++++++++----- generic/tclNamesp.c | 2 +- generic/tclOOMethod.c | 2 +- 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cde1cb9..22ec6b0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4188,10 +4188,6 @@ TclNREvalObjv( return result; } - if (cmdPtr) { - goto commandFound; - } - /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4201,6 +4197,10 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } + if (cmdPtr) { + goto commandFound; + } + /* * Configure evaluation context to match the requested flags. */ @@ -6620,9 +6620,11 @@ TclObjInvoke( Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } +#if 1 if (TclInterpReady(interp) == TCL_ERROR) { return TCL_ERROR; } +#endif cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6638,6 +6640,7 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); +#if 1 /* * Invoke the command function. */ @@ -6669,6 +6672,9 @@ TclObjInvoke( iPtr->flags &= ~ERR_ALREADY_LOGGED; } return result; +#else + +#endif } /* @@ -8243,7 +8249,8 @@ Tcl_NRCmdSwap( Tcl_Obj *const objv[], int flags) { - return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd); + return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, + (Command *) cmd); } /***************************************************************************** diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index aed623a..bdd5386 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1942,7 +1942,7 @@ InvokeImportedNRCmd( Command *realCmdPtr = dataPtr->realCmdPtr; TclSkipTailcall(interp); - return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0); + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } static int diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 98b4078..bd2744a 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1429,7 +1429,7 @@ InvokeForwardMethod( contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, cmdPtr); } static int -- cgit v0.12 From e3cbe63dfbcaaa99f3e56c4c6b3becafa0fa7d33 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 9 Apr 2013 19:04:04 +0000 Subject: Use the double-secret iPtr->lookupNsPtr field to get post-enter-trace re-resolutions of commands done in the right context for oo forwards. --- generic/tclOOMethod.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 98b4078..5296397 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1429,6 +1429,7 @@ InvokeForwardMethod( contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); + ((Interp *)interp)->lookupNsPtr = contextPtr->oPtr->namespacePtr; return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); } -- cgit v0.12 From 6f7f64c938f98f268b7e606cf668c40ca66e98c9 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 9 Apr 2013 20:01:08 +0000 Subject: added some test cases, based on bug report --- tests/oo.test | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 63 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index 49fe150..84e6236 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -936,6 +936,69 @@ test oo-6.18 {Bug 3408830: more forwarding cases} -setup { } -returnCodes error -cleanup { fooClass destroy } -result {wrong # args: should be "::foo len string"} +test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup { + oo::object create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::objdefine foo { + method target {} {lappend ::result instance} + forward bar my target + method bump {} { + set ns [info object namespace ::foo] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + foo destroy +} -result {instance instance instance instance instance instance} +test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup { + oo::class create fooClass + fooClass create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::define fooClass { + method target {} {lappend ::result class} + forward bar my target + method bump {} { + set ns [info object namespace [self]] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + fooClass destroy +} -result {class class class class class class} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass -- cgit v0.12 From 2816004e58ac0da7bde02b0159b164e54c04ab6a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 14:39:56 +0000 Subject: New internal routine TclNRInvoke() - NR-enabled path through the machinery behind invokehidden commands. --- generic/tclBasic.c | 77 +++++++++++++++++++++-------------------------------- generic/tclInt.h | 1 + generic/tclInterp.c | 7 ++++- 3 files changed, 37 insertions(+), 48 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 22ec6b0..82ce385 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -162,6 +162,7 @@ static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_NRPostProc NRPostInvoke; MODULE_SCOPE const TclStubs tclStubs; @@ -6599,32 +6600,32 @@ TclObjInvoke( * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { - register Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - const char *cmdName; /* Name of the command from objv[0]. */ - Tcl_HashEntry *hPtr = NULL; - Command *cmdPtr; - int result; - if (interp == NULL) { return TCL_ERROR; } - if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal argument vector", -1)); return TCL_ERROR; } - if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } + return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); +} -#if 1 - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#endif +int +TclNRInvoke( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + const char *cmdName; /* Name of the command from objv[0]. */ + Tcl_HashEntry *hPtr = NULL; + Command *cmdPtr; cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6640,41 +6641,23 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); -#if 1 - /* - * Invoke the command function. - */ - - iPtr->cmdCount++; - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, objc, objv); - } - - /* - * If an error occurred, record information about what was being executed - * when the error occurred. - */ - - if ((result == TCL_ERROR) - && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) - && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { - int length; - Tcl_Obj *command = Tcl_NewListObj(objc, objv); - const char *cmdString; + /* Avoid the exception-handling brain damage when numLevels == 0 . */ + iPtr->numLevels++; + Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); + + /* TODO: how to get re-resolution right */ + return TclNREvalObjv(interp, objc, objv, 0, cmdPtr); +} - Tcl_IncrRefCount(command); - cmdString = Tcl_GetStringFromObj(command, &length); - Tcl_LogCommandInfo(interp, cmdString, cmdString, length); - Tcl_DecrRefCount(command); - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } +static int +NRPostInvoke( + ClientData clientData[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *)interp; + iPtr->numLevels--; return result; -#else - -#endif } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 1f939c0..70d6d02 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2739,6 +2739,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 1a4297b..ac51d9d 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3052,7 +3052,12 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + if (interp == slaveInterp) { + Tcl_Release(slaveInterp); + return TclNRInvoke(NULL, slaveInterp, objc, objv); + } else { + result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + } } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; -- cgit v0.12 From 87dc28ad0ec271d380acc051908672eb9a3adb43 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 19:36:37 +0000 Subject: More revisions let multi-interp test case work, but at cost of panics and segfaults. Pushing the NRE-envelope. --- generic/tclInterp.c | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ac51d9d..e9ed790 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -279,6 +279,7 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); +static Tcl_NRPostProc NRPostInvokeHidden; /* *---------------------------------------------------------------------- @@ -3056,7 +3057,9 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + NULL, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } } else { Namespace *nsPtr, *dummy1, *dummy2; @@ -3076,6 +3079,19 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return result; } + +static int +NRPostInvokeHidden( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + + Tcl_TransferResult(slaveInterp, result, interp); + Tcl_Release(slaveInterp); + return result; +} /* *---------------------------------------------------------------------- -- cgit v0.12 From f54af08a171ccb68fa91d72cead431736ff19908 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 21:30:40 +0000 Subject: More progress. NR-enable [interp] and [$slave], completely with invokehidden subcommand. Test suite passes with no errors. --- generic/tclInterp.c | 51 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index e9ed790..0da5d47 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -279,7 +279,12 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); + +/* NRE enabling */ static Tcl_NRPostProc NRPostInvokeHidden; +static Tcl_ObjCmdProc NRInterpCmd; +static Tcl_ObjCmdProc NRSlaveCmd; + /* *---------------------------------------------------------------------- @@ -482,7 +487,8 @@ TclInterpInit( slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, + NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -591,6 +597,16 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); +} + +static int +NRInterpCmd( + ClientData clientData, /* Unused. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp; int index; static const char *const options[] = { @@ -2373,8 +2389,8 @@ SlaveCreate( slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, + SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); @@ -2463,6 +2479,16 @@ SlaveObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); +} + +static int +NRSlaveCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { @@ -3053,14 +3079,11 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - if (interp == slaveInterp) { - Tcl_Release(slaveInterp); - return TclNRInvoke(NULL, slaveInterp, objc, objv); - } else { - Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, - NULL, NULL, NULL); - return TclNRInvoke(NULL, slaveInterp, objc, objv); - } + NRE_callback *rootPtr = TOP_CB(slaveInterp); + + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + rootPtr, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; @@ -3087,8 +3110,12 @@ NRPostInvokeHidden( int result) { Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + NRE_callback *rootPtr = (NRE_callback *)data[1]; - Tcl_TransferResult(slaveInterp, result, interp); + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } Tcl_Release(slaveInterp); return result; } -- cgit v0.12 From c8d7d8d2c4ef013886f128bb047b2c9a496a9608 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 8 May 2013 08:24:54 +0000 Subject: Also get msgcat locale from Vista+ registry key "HCU/Control Panel/Desktop : PreferredUILanguages" to honor installed language packs. msgcat now 1.5.2 --- ChangeLog | 7 +++++++ library/msgcat/msgcat.tcl | 39 ++++++++++++++++++++++----------------- library/msgcat/pkgIndex.tcl | 2 +- 3 files changed, 30 insertions(+), 18 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6330666..05754ac 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2013-05-08 Harald Oehlmann + + * library/msgcat/msgcat.tcl: [Bug 3036566]: Also get locale from + registry key HCU/Control Panel/Desktop : PreferredUILanguages to + honor installed language packs on Vista+. + Bumped msgcat version to 1.5.2 + 2013-05-06 Jan Nijtmans * generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 5f0ba2e..cf3b9d7 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -13,7 +13,7 @@ package require Tcl 8.5 # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.5.1 +package provide msgcat 1.5.2 namespace eval msgcat { namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ @@ -541,8 +541,11 @@ proc msgcat::Init {} { # settings, or fall back on locale of "C". # - # First check registry value LocalName present from Windows Vista - # which contains the local string as RFC5646, composed of: + # On Vista and later: + # HCU/Control Panel/Desktop : PreferredUILanguages is for language packs, + # HCU/Control Pannel/International : localName is the default locale. + # + # They contain the local string as RFC5646, composed of: # [a-z]{2,3} : language # -[a-z]{4} : script (optional, translated by table Latn->latin) # -[a-z]{2}|[0-9]{3} : territory (optional, numerical region codes not used) @@ -550,23 +553,25 @@ proc msgcat::Init {} { # Those are translated to local strings. # Examples: de-CH -> de_ch, sr-Latn-CS -> sr_cs@latin, es-419 -> es # - set key {HKEY_CURRENT_USER\Control Panel\International} - if {![catch {registry get $key LocaleName} localeName] - && [regexp {^([a-z]{2,3})(?:-([a-z]{4}))?(?:-([a-z]{2}))?(?:-.+)?$}\ - [string tolower $localeName] match locale script territory]} { - if {"" ne $territory} { - append locale _ $territory - } - set modifierDict [dict create latn latin cyrl cyrillic] - if {[dict exists $modifierDict $script]} { - append locale @ [dict get $modifierDict $script] - } - if {![catch {mclocale [ConvertLocale $locale]}]} { - return + foreach key {{HKEY_CURRENT_USER\Control Panel\Desktop} {HKEY_CURRENT_USER\Control Panel\International}}\ + value {PreferredUILanguages localeName} { + if {![catch {registry get $key $value} localeName] + && [regexp {^([a-z]{2,3})(?:-([a-z]{4}))?(?:-([a-z]{2}))?(?:-.+)?$}\ + [string tolower $localeName] match locale script territory]} { + if {"" ne $territory} { + append locale _ $territory + } + set modifierDict [dict create latn latin cyrl cyrillic] + if {[dict exists $modifierDict $script]} { + append locale @ [dict get $modifierDict $script] + } + if {![catch {mclocale [ConvertLocale $locale]}]} { + return + } } } - # then check key locale which contains a numerical language ID + # then check value locale which contains a numerical language ID if {[catch { set locale [registry get $key "locale"] }]} { diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 3fdb25a..5fabfe3 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded msgcat 1.5.1 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.5.2 [list source [file join $dir msgcat.tcl]] -- cgit v0.12 From e2a50ce38b041d5de04fe4452ddf710c5a9ea999 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 8 May 2013 08:40:22 +0000 Subject: Add install references and changes entry --- ChangeLog | 2 +- changes | 4 ++++ unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 9 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index 05754ac..81d6507 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,7 @@ 2013-05-08 Harald Oehlmann * library/msgcat/msgcat.tcl: [Bug 3036566]: Also get locale from - registry key HCU/Control Panel/Desktop : PreferredUILanguages to + registry key HCU\Control Panel\Desktop : PreferredUILanguages to honor installed language packs on Vista+. Bumped msgcat version to 1.5.2 diff --git a/changes b/changes index 63c3877..d3bbb43 100644 --- a/changes +++ b/changes @@ -8163,3 +8163,7 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) 2012-12-13 (bug fix) crash: [zlib gunzip $data -header noSuchNs::var] (porter) --- Released 8.6.0, December 20, 2012 --- See ChangeLog for details --- + +2013-05-08 (bug fix)[3036566] Honor language packs on Vista+ to get initial locale (oehlmann) +=> msgcat 1.5.2 + diff --git a/unix/Makefile.in b/unix/Makefile.in index 3b14752..1c84540 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -838,8 +838,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.5.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.1.tm; + @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.5 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 6f5211e..12c04bc 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -646,8 +646,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.5.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.1.tm; + @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.5 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; @echo "Installing package platform 1.0.11 as a Tcl Module"; -- cgit v0.12 From 88149255f5ae41c5f0580c6564b56f69087efa73 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 8 May 2013 14:52:51 +0000 Subject: Document mcunknown format parameters --- doc/msgcat.n | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index 47b6bf7..44f96e6 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -35,7 +35,7 @@ msgcat \- Tcl message catalog \fB::msgcat::mcflmset \fIsrc-trans-list\fR .VE "TIP 404" .sp -\fB::msgcat::mcunknown \fIlocale src-string\fR +\fB::msgcat::mcunknown \fIlocale src-string \fR?\fargs\fR? .BE .SH DESCRIPTION .PP @@ -157,12 +157,13 @@ translate-string\fR ?\fIsrc-string translate-string ...\fR?} of \fB::msgcat::mcflset\fR. The function returns the number of translations set. .VE "TIP 404" .TP -\fB::msgcat::mcunknown \fIlocale src-string\fR +\fB::msgcat::mcunknown \fIlocale src-string \fR?\fargs\fR? . This routine is called by \fB::msgcat::mc\fR in the case when a translation for \fIsrc-string\fR is not defined in the current locale. The default action is to return -\fIsrc-string\fR. This procedure can be redefined by the +\fIsrc-string\fR passed by format if there are any arguments. This +procedure can be redefined by the application, for example to log error messages for each unknown string. The \fB::msgcat::mcunknown\fR procedure is invoked at the same stack context as the call to \fB::msgcat::mc\fR. The return value -- cgit v0.12 From b5df26a280112129ffcd34f74456cc6f2980e5be Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 8 May 2013 15:47:31 +0000 Subject: Corrected args -> arg arg ... in msgcat doc --- doc/msgcat.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/msgcat.n b/doc/msgcat.n index 44f96e6..bfd94ae 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -35,7 +35,7 @@ msgcat \- Tcl message catalog \fB::msgcat::mcflmset \fIsrc-trans-list\fR .VE "TIP 404" .sp -\fB::msgcat::mcunknown \fIlocale src-string \fR?\fargs\fR? +\fB::msgcat::mcunknown \fIlocale src-string\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP @@ -157,7 +157,7 @@ translate-string\fR ?\fIsrc-string translate-string ...\fR?} of \fB::msgcat::mcflset\fR. The function returns the number of translations set. .VE "TIP 404" .TP -\fB::msgcat::mcunknown \fIlocale src-string \fR?\fargs\fR? +\fB::msgcat::mcunknown \fIlocale src-string\fR ?\fIarg arg ...\fR? . This routine is called by \fB::msgcat::mc\fR in the case when a translation for \fIsrc-string\fR is not defined in the -- cgit v0.12 From 2e2a7f14b404980bdc7423407ddb866901ca14a5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 May 2013 15:08:48 +0000 Subject: - eliminate compiler warning when compiling with Visual Studio. - Make sure that _ftime() from msvcrt.dll is used, not ftime() from mingw (which might use 64-bit time_t) --- generic/tclBasic.c | 1 + win/tclWinTime.c | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 0fd025a..757f9ca 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -19,6 +19,7 @@ # define _USE_32BIT_TIME_T #endif +#include #include "tclInt.h" #include "tclCompile.h" #ifndef TCL_GENERIC_ONLY diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 8bbd8fd..8fdc071 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -258,7 +258,7 @@ void Tcl_GetTime(timePtr) Tcl_Time *timePtr; /* Location to store time information. */ { - struct timeb t; + struct _timeb t; int useFtime = 1; /* Flag == TRUE if we need to fall back * on ftime rather than using the perf @@ -431,7 +431,7 @@ Tcl_GetTime(timePtr) if ( useFtime ) { /* High resolution timer is not available. Just use ftime */ - ftime(&t); + _ftime(&t); timePtr->sec = (long)t.time; timePtr->usec = t.millitm * 1000; } -- cgit v0.12 From 747454fc55e9245072dd7689c036322331e747f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 May 2013 15:12:27 +0000 Subject: inclusion is only needed when compiling for Win32, don't bother for other platforms. --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 757f9ca..6e457c0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -17,9 +17,9 @@ #if defined(_WIN32) && !defined(_WIN64) # define _USE_32BIT_TIME_T +# include #endif -#include #include "tclInt.h" #include "tclCompile.h" #ifndef TCL_GENERIC_ONLY -- cgit v0.12 From 4e4b54aad334a0c55a28cbc05206ded0cebb9dca Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 18 May 2013 13:25:11 +0000 Subject: Split tclCompCmds.c into two roughly-equal-sized pieces. --- ChangeLog | 9 +- generic/tclCompCmds.c | 2963 +------------------------------------------ generic/tclCompCmdsGR.c | 3244 +++++++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 14 +- win/Makefile.in | 1 + win/makefile.bc | 1 + win/makefile.vc | 1 + 7 files changed, 3295 insertions(+), 2938 deletions(-) create mode 100644 generic/tclCompCmdsGR.c diff --git a/ChangeLog b/ChangeLog index 99d9205..6b9f044 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,12 @@ +2013-05-18 Donal K. Fellows + + * generic/tclCompCmdsGR.c: Split tclCompCmds.c again to keep size of + code down. + 2013-05-16 Jan Nijtmans - * generic/tclBasic.c: Add panic in order to detect - incompatible mingw32 sys/stat.h and sys/time.h headers, + * generic/tclBasic.c: Add panic in order to detect incompatible + mingw32 sys/stat.h and sys/time.h headers. 2013-05-13 Jan Nijtmans diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a5678bf..2ac0fe3 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -7,7 +7,7 @@ * Copyright (c) 1997-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2004-2006 by Donal K. Fellows. + * Copyright (c) 2004-2013 by Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -31,11 +31,6 @@ static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); -static void CompileReturnInternal(CompileEnv *envPtr, - unsigned char op, int code, int level, - Tcl_Obj *returnOpts); -static int IndexTailVarIfKnown(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr); static int PushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, @@ -2588,6 +2583,37 @@ TclCompileForeachCmd( /* *---------------------------------------------------------------------- * + * TclCompileLmapCmd -- + * + * Procedure called to compile the "lmap" 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 "lmap" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLmapCmd( + 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. */ +{ + return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_COLLECT); +} + +/* + *---------------------------------------------------------------------- + * * CompileEachloopCmd -- * * Procedure called to compile the "foreach" and "lmap" commands. @@ -3303,2931 +3329,6 @@ TclCompileFormatCmd( /* *---------------------------------------------------------------------- * - * TclCompileGlobalCmd -- - * - * Procedure called to compile the "global" 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 "global" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileGlobalCmd( - 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 *varTokenPtr; - int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords; - if (numWords < 2) { - return TCL_ERROR; - } - - /* - * 'global' has no effect outside of proc bodies; handle that at runtime - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - PushLiteral(envPtr, "::", 2); - - /* - * Loop over the variables. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { - localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - - if (localIndex < 0) { - return TCL_ERROR; - } - - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); - } - - /* - * Pop the namespace, and set the result to empty - */ - - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileIfCmd -- - * - * Procedure called to compile the "if" 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 "if" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileIfCmd( - 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. */ -{ - JumpFixupArray jumpFalseFixupArray; - /* Used to fix the ifFalse jump after each - * test when its target PC is determined. */ - JumpFixupArray jumpEndFixupArray; - /* Used to fix the jump after each "then" body - * to the end of the "if" when that PC is - * determined. */ - Tcl_Token *tokenPtr, *testTokenPtr; - int jumpIndex = 0; /* Avoid compiler warning. */ - int jumpFalseDist, numWords, wordIdx, numBytes, j, code; - const char *word; - int savedStackDepth = envPtr->currStackDepth; - /* Saved stack depth at the start of the first - * test; the envPtr current depth is restored - * to this value at the start of each test. */ - int realCond = 1; /* Set to 0 for static conditions: - * "if 0 {..}" */ - int boolVal; /* Value of static condition. */ - int compileScripts = 1; - DefineLineInformation; /* TIP #280 */ - - /* - * Only compile the "if" command if all arguments are simple words, in - * order to insure correct substitution [Bug 219166] - */ - - tokenPtr = parsePtr->tokenPtr; - wordIdx = 0; - numWords = parsePtr->numWords; - - for (wordIdx = 0; wordIdx < numWords; wordIdx++) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - } - - TclInitJumpFixupArray(&jumpFalseFixupArray); - TclInitJumpFixupArray(&jumpEndFixupArray); - code = TCL_OK; - - /* - * Each iteration of this loop compiles one "if expr ?then? body" or - * "elseif expr ?then? body" clause. - */ - - tokenPtr = parsePtr->tokenPtr; - wordIdx = 0; - while (wordIdx < numWords) { - /* - * Stop looping if the token isn't "if" or "elseif". - */ - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((tokenPtr == parsePtr->tokenPtr) - || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - } else { - break; - } - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - - /* - * Compile the test expression then emit the conditional jump around - * the "then" part. - */ - - envPtr->currStackDepth = savedStackDepth; - testTokenPtr = tokenPtr; - - if (realCond) { - /* - * Find out if the condition is a constant. - */ - - Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, - testTokenPtr[1].size); - - Tcl_IncrRefCount(boolObj); - code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); - if (code == TCL_OK) { - /* - * A static condition. - */ - - realCond = 0; - if (!boolVal) { - compileScripts = 0; - } - } else { - SetLineInformation(wordIdx); - Tcl_ResetResult(interp); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { - TclExpandJumpFixupArray(&jumpFalseFixupArray); - } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - jumpFalseFixupArray.fixup+jumpIndex); - } - code = TCL_OK; - } - - /* - * Skip over the optional "then" before the then clause. - */ - - tokenPtr = TokenAfter(testTokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - } - } - - /* - * Compile the "then" command body. - */ - - if (compileScripts) { - SetLineInformation(wordIdx); - envPtr->currStackDepth = savedStackDepth; - CompileBody(envPtr, tokenPtr, interp); - } - - if (realCond) { - /* - * Jump to the end of the "if" command. Both jumpFalseFixupArray - * and jumpEndFixupArray are indexed by "jumpIndex". - */ - - if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { - TclExpandJumpFixupArray(&jumpEndFixupArray); - } - jumpEndFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - jumpEndFixupArray.fixup+jumpIndex); - - /* - * Fix the target of the jumpFalse after the test. Generate a 4 - * byte jump if the distance is > 120 bytes. This is conservative, - * and ensures that we won't have to replace this jump if we later - * also need to replace the proceeding jump to the end of the "if" - * with a 4 byte jump. - */ - - if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup+jumpIndex, 120)) { - /* - * Adjust the code offset for the proceeding jump to the end - * of the "if" command. - */ - - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; - } - } else if (boolVal) { - /* - * We were processing an "if 1 {...}"; stop compiling scripts. - */ - - compileScripts = 0; - } else { - /* - * We were processing an "if 0 {...}"; reset so that the rest - * (elseif, else) is compiled correctly. - */ - - realCond = 1; - compileScripts = 1; - } - - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - } - - /* - * Restore the current stack depth in the environment; the "else" clause - * (or its default) will add 1 to this. - */ - - envPtr->currStackDepth = savedStackDepth; - - /* - * Check for the optional else clause. Do not compile anything if this was - * an "if 1 {...}" case. - */ - - if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - /* - * There is an else clause. Skip over the optional "else" word. - */ - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - } - - if (compileScripts) { - /* - * Compile the else command body. - */ - - SetLineInformation(wordIdx); - CompileBody(envPtr, tokenPtr, interp); - } - - /* - * Make sure there are no words after the else clause. - */ - - wordIdx++; - if (wordIdx < numWords) { - code = TCL_ERROR; - goto done; - } - } else { - /* - * No else clause: the "if" command's result is an empty string. - */ - - if (compileScripts) { - PushLiteral(envPtr, "", 0); - } - } - - /* - * Fix the unconditional jumps to the end of the "if" command. - */ - - for (j = jumpEndFixupArray.next; j > 0; j--) { - jumpIndex = (j - 1); /* i.e. process the closest jump first. */ - if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup+jumpIndex, 127)) { - /* - * Adjust the immediately preceeding "ifFalse" jump. We moved it's - * target (just after this jump) down three bytes. - */ - - unsigned char *ifFalsePc = envPtr->codeStart - + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; - unsigned char opCode = *ifFalsePc; - - if (opCode == INST_JUMP_FALSE1) { - jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else if (opCode == INST_JUMP_FALSE4) { - jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); - } - } - } - - /* - * Free the jumpFixupArray array if malloc'ed storage was used. - */ - - done: - envPtr->currStackDepth = savedStackDepth + 1; - TclFreeJumpFixupArray(&jumpFalseFixupArray); - TclFreeJumpFixupArray(&jumpEndFixupArray); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileIncrCmd -- - * - * Procedure called to compile the "incr" 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 "incr" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileIncrCmd( - 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 *varTokenPtr, *incrTokenPtr; - int simpleVarName, isScalar, localIndex, haveImmValue, immValue; - DefineLineInformation; /* TIP #280 */ - - if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { - return TCL_ERROR; - } - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, - &localIndex, &simpleVarName, &isScalar, 1); - - /* - * If an increment is given, push it, but see first if it's a small - * integer. - */ - - haveImmValue = 0; - immValue = 1; - if (parsePtr->numWords == 3) { - incrTokenPtr = TokenAfter(varTokenPtr); - if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - const char *word = incrTokenPtr[1].start; - int numBytes = incrTokenPtr[1].size; - int code; - Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); - - Tcl_IncrRefCount(intObj); - code = TclGetIntFromObj(NULL, intObj, &immValue); - TclDecrRefCount(intObj); - if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { - haveImmValue = 1; - } - if (!haveImmValue) { - PushLiteral(envPtr, word, numBytes); - } - } else { - SetLineInformation(2); - CompileTokens(envPtr, incrTokenPtr, interp); - } - } else { /* No incr amount given so use 1. */ - haveImmValue = 1; - } - - /* - * Emit the instruction to increment the variable. - */ - - if (!simpleVarName) { - if (haveImmValue) { - TclEmitInstInt1( INST_INCR_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_STK, envPtr); - } - } else if (isScalar) { /* Simple scalar variable. */ - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); - } - } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_SCALAR_STK, envPtr); - } - } - } else { /* Simple array variable. */ - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); - } - } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr); - } - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileInfo*Cmd -- - * - * Procedures called to compile "info" subcommands. - * - * 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 "info" subcommand at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileInfoCommandsCmd( - 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) -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - char *bytes; - - /* - * We require one compile-time known argument for the case we can compile. - */ - - if (parsePtr->numWords == 1) { - return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } else if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - objPtr = Tcl_NewObj(); - Tcl_IncrRefCount(objPtr); - if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - goto notCompilable; - } - bytes = Tcl_GetString(objPtr); - - /* - * We require that the argument start with "::" and not have any of "*\[?" - * in it. (Theoretically, we should look in only the final component, but - * the difference is so slight given current naming practices.) - */ - - if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) { - goto notCompilable; - } - Tcl_DecrRefCount(objPtr); - - /* - * Confirmed as a literal that will not frighten the horses. Compile. Note - * that the result needs to be list-ified. - */ - - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_STR_LEN, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); - TclEmitInstInt4( INST_LIST, 1, envPtr); - return TCL_OK; - - notCompilable: - Tcl_DecrRefCount(objPtr); - return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileInfoCoroutineCmd( - 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. */ -{ - /* - * Only compile [info coroutine] without arguments. - */ - - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_COROUTINE_NAME, envPtr); - return TCL_OK; -} - -int -TclCompileInfoExistsCmd( - 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; - int isScalar, simpleVarName, localIndex; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, - &simpleVarName, &isScalar, 1); - - /* - * Emit instruction to check the variable for existence. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_EXIST_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_EXIST_STK, envPtr); - } else { - TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr); - } else { - TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -int -TclCompileInfoLevelCmd( - 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. */ -{ - /* - * Only compile [info level] without arguments or with a single argument. - */ - - if (parsePtr->numWords == 1) { - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); - } else if (parsePtr->numWords != 2) { - return TCL_ERROR; - } else { - DefineLineInformation; /* TIP #280 */ - - /* - * Compile the argument, then add the instruction to convert it into a - * list of arguments. - */ - - SetLineInformation(1); - CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); - TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); - } - return TCL_OK; -} - -int -TclCompileInfoObjectClassCmd( - 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) -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_TCLOO_CLASS, envPtr); - return TCL_OK; -} - -int -TclCompileInfoObjectIsACmd( - 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) -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * We only handle [info object isa object ]. The first three - * words are compressed to a single token by the ensemble compilation - * engine. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 - || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - - /* - * Issue the code. - */ - - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); - return TCL_OK; -} - -int -TclCompileInfoObjectNamespaceCmd( - 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) -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_TCLOO_NS, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLappendCmd -- - * - * Procedure called to compile the "lappend" 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 "lappend" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLappendCmd( - 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 *varTokenPtr, *valueTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i, fwd, offsetFwd; - DefineLineInformation; /* TIP #280 */ - - /* - * If we're not in a procedure, don't compile. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - if (numWords == 1) { - return TCL_ERROR; - } - if (numWords != 3) { - /* - * LAPPEND instructions currently only handle one value, but we can - * handle some multi-value cases by stringing them together. - */ - - goto lappendMultiple; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we - * need to emit code to compute and push the name at runtime. We use a - * frame slot (entry in the array of local vars) if we are compiling a - * procedure body and if the name is simple text that does not include - * namespace qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - /* - * If we are doing an assignment, push the new value. In the no values - * case, create an empty object. - */ - - if (numWords > 2) { - Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); - - CompileWord(envPtr, valueTokenPtr, interp, 2); - } - - /* - * Emit instructions to set/get the variable. - */ - - /* - * The *_STK opcodes should be refactored to make better use of existing - * LOAD/STORE instructions. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_LAPPEND_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_STK, envPtr); - } else { - Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; - - lappendMultiple: - /* - * Can only handle the case where we are appending to a local scalar when - * there are multiple values to append. Fortunately, this is common. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &simpleVarName, &isScalar, 1); - if (!isScalar || localIndex < 0) { - return TCL_ERROR; - } - - /* - * Definitely appending to a local scalar; generate the words and append - * them. - */ - - valueTokenPtr = TokenAfter(varTokenPtr); - for (i = 2 ; i < numWords ; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); - valueTokenPtr = TokenAfter(valueTokenPtr); - } - TclEmitInstInt4( INST_LIST, numWords-2, envPtr); - TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLassignCmd -- - * - * Procedure called to compile the "lassign" 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 "lassign" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLassignCmd( - 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; - int simpleVarName, isScalar, localIndex, numWords, idx; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords; - - /* - * Check for command syntax error, but we'll punt that to runtime. - */ - - if (numWords < 3) { - return TCL_ERROR; - } - - /* - * Generate code to push list being taken apart by [lassign]. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* - * Generate code to assign values from the list to variables. - */ - - for (idx=0 ; idx= 0) { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - } else { - if (localIndex >= 0) { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else { - TclEmitInstInt4(INST_OVER, 2, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - } - } - - /* - * Generate code to leave the rest of the list on the stack. - */ - - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( -2 /* == "end" */, envPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLindexCmd -- - * - * Procedure called to compile the "lindex" 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 "lindex" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLindexCmd( - 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 *idxTokenPtr, *valTokenPtr; - int i, numWords = parsePtr->numWords; - DefineLineInformation; /* TIP #280 */ - - /* - * Quit if too few args. - */ - - if (numWords <= 1) { - return TCL_ERROR; - } - - valTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (numWords != 3) { - goto emitComplexLindex; - } - - 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 the conversion failed or the value was negative, we just keep on - * going with the more complex compilation. - */ - } - - /* - * Push the operands onto the stack. - */ - - emitComplexLindex: - for (i=1 ; inumWords == 1) { - /* - * [list] without arguments just pushes an empty object. - */ - - PushLiteral(envPtr, "", 0); - return TCL_OK; - } - - /* - * Test if all arguments are compile-time known. If they are, we can - * implement with a simple push. - */ - - numWords = parsePtr->numWords; - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - listObj = Tcl_NewObj(); - for (i = 1; i < numWords && listObj != NULL; i++) { - objPtr = Tcl_NewObj(); - if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) { - (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); - } else { - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(listObj); - listObj = NULL; - } - valueTokenPtr = TokenAfter(valueTokenPtr); - } - if (listObj != NULL) { - int len; - const char *bytes = Tcl_GetStringFromObj(listObj, &len); - - PushLiteral(envPtr, bytes, len); - Tcl_DecrRefCount(listObj); - if (len > 0) { - /* - * Force list interpretation! - */ - - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - return TCL_OK; - } - - /* - * Push the all values onto the stack. - */ - - numWords = parsePtr->numWords; - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - concat = build = 0; - for (i = 1; i < numWords; i++) { - if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { - TclEmitInstInt4( INST_LIST, build, envPtr); - if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } - build = 0; - concat = 1; - } - CompileWord(envPtr, valueTokenPtr, interp, i); - if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else { - concat = 1; - } - } else { - build++; - } - valueTokenPtr = TokenAfter(valueTokenPtr); - } - if (build > 0) { - TclEmitInstInt4( INST_LIST, build, envPtr); - if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } - } - - /* - * If there was just one expanded word, we must ensure that it is a list - * at this point. We use an [lrange ... 0 end] for this (instead of - * [llength], as with literals) as we must drop any string representation - * that might be hanging around. - */ - - if (concat && numWords == 2) { - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( -2, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLlengthCmd -- - * - * Procedure called to compile the "llength" 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 "llength" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLlengthCmd( - 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 *varTokenPtr; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLrangeCmd -- - * - * How to compile the "lrange" command. We only bother because we needed - * the opcode anyway for "lassign". - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLrangeCmd( - 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, result; - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - listTokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * 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). - */ - - tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - 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) { - return TCL_ERROR; - } - - /* - * 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. - */ - - CompileWord(envPtr, listTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLreplaceCmd -- - * - * 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".) - * - *---------------------------------------------------------------------- - */ - -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, result, guaranteedDropAll = 0; - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - listTokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * 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). - */ - - tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - 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) { - return TCL_ERROR; - } - - /* - * 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]. - */ - - if (idx1 == 0) { - if (idx2 == -2) { - guaranteedDropAll = 1; - } - idx1 = idx2 + 1; - idx2 = -2; - } else if (idx2 == -2) { - idx2 = idx1 - 1; - idx1 = 0; - } else { - return TCL_ERROR; - } - - /* - * 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. - */ - - CompileWord(envPtr, listTokenPtr, interp, 1); - if (guaranteedDropAll) { - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - } else { - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLsetCmd -- - * - * Procedure called to compile the "lset" 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 "lset" command at - * runtime. - * - * The general template for execution of the "lset" command is: - * (1) Instructions to push the variable name, unless the variable is - * local to the stack frame. - * (2) If the variable is an array element, instructions to push the - * array element name. - * (3) Instructions to push each of zero or more "index" arguments to the - * stack, followed with the "newValue" element. - * (4) Instructions to duplicate the variable name and/or array element - * name onto the top of the stack, if either was pushed at steps (1) - * and (2). - * (5) The appropriate INST_LOAD_* instruction to place the original - * value of the list variable at top of stack. - * (6) At this point, the stack contains: - * varName? arrayElementName? index1 index2 ... newValue oldList - * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST - * according as whether there is exactly one index element (LIST) or - * either zero or else two or more (FLAT). This instruction removes - * everything from the stack except for the two names and pushes the - * new value of the variable. - * (7) Finally, INST_STORE_* stores the new value in the variable and - * cleans up the stack. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLsetCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - 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. */ -{ - int tempDepth; /* Depth used for emitting one part of the - * code burst. */ - Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the - * parse of the variable name. */ - int localIndex; /* Index of var in local var table. */ - int simpleVarName; /* Flag == 1 if var name is simple. */ - int isScalar; /* Flag == 1 if scalar, 0 if array. */ - int i; - DefineLineInformation; /* TIP #280 */ - - /* - * Check argument count. - */ - - if (parsePtr->numWords < 3) { - /* - * Fail at run time, not in compilation. - */ - - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - /* - * Push the "index" args and the new element value. - */ - - for (i=2 ; inumWords ; ++i) { - varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, i); - } - - /* - * Duplicate the variable name if it's been pushed. - */ - - if (!simpleVarName || localIndex < 0) { - if (!simpleVarName || isScalar) { - tempDepth = parsePtr->numWords - 2; - } else { - tempDepth = parsePtr->numWords - 1; - } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); - } - - /* - * Duplicate an array index if one's been pushed. - */ - - if (simpleVarName && !isScalar) { - if (localIndex < 0) { - tempDepth = parsePtr->numWords - 1; - } else { - tempDepth = parsePtr->numWords - 2; - } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); - } - - /* - * Emit code to load the variable's value. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_LOAD_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); - } - } - - /* - * Emit the correct variety of 'lset' instruction. - */ - - if (parsePtr->numWords == 4) { - TclEmitOpcode( INST_LSET_LIST, envPtr); - } else { - TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); - } - - /* - * Emit code to put the value back in the variable. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_STORE_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); - } else { - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLmapCmd -- - * - * Procedure called to compile the "lmap" 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 "lmap" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLmapCmd( - 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. */ -{ - return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_COLLECT); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileNamespace*Cmd -- - * - * Procedures called to compile the "namespace" command; currently, only - * the subcommands "namespace current" and "namespace upvar" are compiled - * to bytecodes, and the latter only inside a procedure(-like) context. - * - * 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 "namespace upvar" - * command at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileNamespaceCurrentCmd( - 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. */ -{ - /* - * Only compile [namespace current] without arguments. - */ - - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_NS_CURRENT, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceCodeCmd( - 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); - - /* - * The specification of [namespace code] is rather shocking, in that it is - * supposed to check if the argument is itself the result of [namespace - * code] and not apply itself in that case. Which is excessively cautious, - * but what the test suite checks for. - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20 - && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) { - /* - * Technically, we could just pass a literal '::namespace inscope ' - * term through, but that's something which really shouldn't be - * occurring as something that the user writes so we'll just punt it. - */ - - return TCL_ERROR; - } - - /* - * Now we can compile using the same strategy as [namespace code]'s normal - * implementation does internally. Note that we can't bind the namespace - * name directly here, because TclOO plays complex games with namespaces; - * the value needs to be determined at runtime for safety. - */ - - PushLiteral(envPtr, "::namespace", 11); - PushLiteral(envPtr, "inscope", 7); - TclEmitOpcode( INST_NS_CURRENT, envPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST, 4, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceQualifiersCmd( - 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 = TokenAfter(parsePtr->tokenPtr); - DefineLineInformation; /* TIP #280 */ - int off; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - CompileWord(envPtr, tokenPtr, interp, 1); - PushLiteral(envPtr, "0", 1); - PushLiteral(envPtr, "::", 2); - TclEmitInstInt4( INST_OVER, 2, envPtr); - TclEmitOpcode( INST_STR_FIND_LAST, envPtr); - off = CurrentOffset(envPtr); - PushLiteral(envPtr, "1", 1); - TclEmitOpcode( INST_SUB, envPtr); - TclEmitInstInt4( INST_OVER, 2, envPtr); - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitOpcode( INST_STR_INDEX, envPtr); - PushLiteral(envPtr, ":", 1); - TclEmitOpcode( INST_STR_EQ, envPtr); - off = off - CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); - TclEmitOpcode( INST_STR_RANGE, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceTailCmd( - 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 = TokenAfter(parsePtr->tokenPtr); - DefineLineInformation; /* TIP #280 */ - JumpFixup jumpFixup; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - /* - * Take care; only add 2 to found index if the string was actually found. - */ - - CompileWord(envPtr, tokenPtr, interp, 1); - PushLiteral(envPtr, "::", 2); - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitOpcode( INST_STR_FIND_LAST, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - PushLiteral(envPtr, "0", 1); - TclEmitOpcode( INST_GE, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); - PushLiteral(envPtr, "2", 1); - TclEmitOpcode( INST_ADD, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); - PushLiteral(envPtr, "end", 3); - TclEmitOpcode( INST_STR_RANGE, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceUpvarCmd( - 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, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Only compile [namespace upvar ...]: needs an even number of args, >=4 - */ - - numWords = parsePtr->numWords; - if ((numWords % 2) || (numWords < 4)) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* - * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a - * local variable, return an error so that the non-compiled command will - * be called at runtime. - */ - - localTokenPtr = tokenPtr; - for (i=3; i<=numWords; i+=2) { - otherTokenPtr = TokenAfter(localTokenPtr); - localTokenPtr = TokenAfter(otherTokenPtr); - - CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - if ((localIndex < 0) || !isScalar) { - return TCL_ERROR; - } - TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); - } - - /* - * Pop the namespace, and set the result to empty - */ - - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -int -TclCompileNamespaceWhichCmd( - 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, *opt; - int idx; - - if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - idx = 1; - - /* - * If there's an option, check that it's "-command". We don't handle - * "-variable" (currently) and anything else is an error. - */ - - if (parsePtr->numWords == 3) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - opt = tokenPtr + 1; - if (opt->size < 2 || opt->size > 8 - || strncmp(opt->start, "-command", opt->size) != 0) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - idx++; - } - - /* - * Issue the bytecode. - */ - - CompileWord(envPtr, tokenPtr, interp, idx); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileRegexpCmd -- - * - * Procedure called to compile the "regexp" 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 "regexp" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileRegexpCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - 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 *varTokenPtr; /* Pointer to the Tcl_Token representing the - * parse of the RE or string. */ - int i, len, nocase, exact, sawLast, simple; - const char *str; - DefineLineInformation; /* TIP #280 */ - - /* - * We are only interested in compiling simple regexp cases. Currently - * supported compile cases are: - * regexp ?-nocase? ?--? staticString $var - * regexp ?-nocase? ?--? {^staticString$} $var - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - simple = 0; - nocase = 0; - sawLast = 0; - varTokenPtr = parsePtr->tokenPtr; - - /* - * We only look for -nocase and -- as options. Everything else gets pushed - * to runtime execution. This is different than regexp's runtime option - * handling, but satisfies our stricter needs. - */ - - for (i = 1; i < parsePtr->numWords - 2; i++) { - varTokenPtr = TokenAfter(varTokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Not a simple string, so punt to runtime. - */ - - return TCL_ERROR; - } - str = varTokenPtr[1].start; - len = varTokenPtr[1].size; - if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { - sawLast++; - i++; - break; - } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { - nocase = 1; - } else { - /* - * Not an option we recognize. - */ - - return TCL_ERROR; - } - } - - if ((parsePtr->numWords - i) != 2) { - /* - * We don't support capturing to variables. - */ - - return TCL_ERROR; - } - - /* - * Get the regexp string. If it is not a simple string or can't be - * converted to a glob pattern, push the word for the INST_REGEXP. - * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. - */ - - varTokenPtr = TokenAfter(varTokenPtr); - - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_DString ds; - - str = varTokenPtr[1].start; - len = varTokenPtr[1].size; - - /* - * If it has a '-', it could be an incorrectly formed regexp command. - */ - - if ((*str == '-') && !sawLast) { - return TCL_ERROR; - } - - if (len == 0) { - /* - * The semantics of regexp are always match on re == "". - */ - - PushLiteral(envPtr, "1", 1); - return TCL_OK; - } - - /* - * Attempt to convert pattern to glob. If successful, push the - * converted pattern as a literal. - */ - - if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) - == TCL_OK) { - simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - - if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); - } - - /* - * Push the string arg. - */ - - varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); - - if (simple) { - if (exact && !nocase) { - TclEmitOpcode( INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr); - } - } else { - /* - * Pass correct RE compile flags. We use only Int1 (8-bit), but - * that handles all the flags we want to pass. - * Don't use TCL_REG_NOSUB as we may have backrefs. - */ - - int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); - - TclEmitInstInt1( INST_REGEXP, cflags, envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileRegsubCmd -- - * - * Procedure called to compile the "regsub" 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 "regsub" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileRegsubCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - 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. */ -{ - /* - * We only compile the case with [regsub -all] where the pattern is both - * known at compile time and simple (i.e., no RE metacharacters). That is, - * the pattern must be translatable into a glob like "*foo*" with no other - * glob metacharacters inside it; there must be some "foo" in there too. - * The substitution string must also be known at compile time and free of - * metacharacters ("\digit" and "&"). Finally, there must not be a - * variable mentioned in the [regsub] to write the result back to (because - * we can't get the count of substitutions that would be the result in - * that case). The key is that these are the conditions under which a - * [string map] could be used instead, in particular a [string map] of the - * form we can compile to bytecode. - * - * In short, we look for: - * - * regsub -all [--] simpleRE string simpleReplacement - * - * The only optional part is the "--", and no other options are handled. - */ - - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *stringTokenPtr; - Tcl_Obj *patternObj = NULL, *replacementObj = NULL; - Tcl_DString pattern; - const char *bytes; - int len, exact, result = TCL_ERROR; - - if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { - return TCL_ERROR; - } - - /* - * Parse the "-all", which must be the first argument (other options not - * supported, non-"-all" substitution we can't compile). - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4 - || strncmp(tokenPtr[1].start, "-all", 4)) { - return TCL_ERROR; - } - - /* - * Get the pattern into patternObj, checking for "--" in the process. - */ - - Tcl_DStringInit(&pattern); - tokenPtr = TokenAfter(tokenPtr); - patternObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { - goto done; - } - if (Tcl_GetString(patternObj)[0] == '-') { - if (strcmp(Tcl_GetString(patternObj), "--") != 0 - || parsePtr->numWords == 5) { - goto done; - } - tokenPtr = TokenAfter(tokenPtr); - Tcl_DecrRefCount(patternObj); - patternObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { - goto done; - } - } else if (parsePtr->numWords == 6) { - goto done; - } - - /* - * Identify the code which produces the string to apply the substitution - * to (stringTokenPtr), and the replacement string (into replacementObj). - */ - - stringTokenPtr = TokenAfter(tokenPtr); - tokenPtr = TokenAfter(stringTokenPtr); - replacementObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { - goto done; - } - - /* - * Next, higher-level checks. Is the RE a very simple glob? Is the - * replacement "simple"? - */ - - bytes = Tcl_GetStringFromObj(patternObj, &len); - if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { - goto done; - } - bytes = Tcl_DStringValue(&pattern); - if (*bytes++ != '*') { - goto done; - } - while (1) { - switch (*bytes) { - case '*': - if (bytes[1] == '\0') { - /* - * OK, we've proved there are no metacharacters except for the - * '*' at each end. - */ - - len = Tcl_DStringLength(&pattern) - 2; - if (len > 0) { - goto isSimpleGlob; - } - - /* - * The pattern is "**"! I believe that should be impossible, - * but we definitely can't handle that at all. - */ - } - case '\0': case '?': case '[': case '\\': - goto done; - } - bytes++; - } - isSimpleGlob: - for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { - switch (*bytes) { - case '\\': case '&': - goto done; - } - } - - /* - * Proved the simplicity constraints! Time to issue the code. - */ - - result = TCL_OK; - bytes = Tcl_DStringValue(&pattern) + 1; - PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(replacementObj, &len); - PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); - TclEmitOpcode( INST_STR_MAP, envPtr); - - done: - Tcl_DStringFree(&pattern); - if (patternObj) { - Tcl_DecrRefCount(patternObj); - } - if (replacementObj) { - Tcl_DecrRefCount(replacementObj); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileReturnCmd -- - * - * Procedure called to compile the "return" 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 "return" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileReturnCmd( - 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. */ -{ - /* - * General syntax: [return ?-option value ...? ?result?] - * An even number of words means an explicit result argument is present. - */ - int level, code, objc, size, status = TCL_OK; - int numWords = parsePtr->numWords; - int explicitResult = (0 == (numWords % 2)); - int numOptionWords = numWords - 1 - explicitResult; - int savedStackDepth = envPtr->currStackDepth; - Tcl_Obj *returnOpts, **objv; - Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - DefineLineInformation; /* TIP #280 */ - - /* - * Check for special case which can always be compiled: - * return -options - * Unlike the normal [return] compilation, this version does everything at - * runtime so it can handle arbitrary words and not just literals. Note - * that if INST_RETURN_STK wasn't already needed for something else - * ('finally' clause processing) this piece of code would not be present. - */ - - if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) - && (wordTokenPtr[1].size == 8) - && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { - Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); - Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); - - CompileWord(envPtr, optsTokenPtr, interp, 2); - CompileWord(envPtr, msgTokenPtr, interp, 3); - TclEmitOpcode(INST_RETURN_STK, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; - } - - /* - * Allocate some working space. - */ - - objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *)); - - /* - * Scan through the return options. If any are unknown at compile time, - * there is no value in bytecompiling. Save the option values known in an - * objv array for merging into a return options dictionary. - */ - - for (objc = 0; objc < numOptionWords; objc++) { - objv[objc] = Tcl_NewObj(); - Tcl_IncrRefCount(objv[objc]); - if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { - /* - * Non-literal, so punt to run-time. - */ - - for (; objc>=0 ; objc--) { - TclDecrRefCount(objv[objc]); - } - TclStackFree(interp, objv); - goto issueRuntimeReturn; - } - wordTokenPtr = TokenAfter(wordTokenPtr); - } - status = TclMergeReturnOptions(interp, objc, objv, - &returnOpts, &code, &level); - while (--objc >= 0) { - TclDecrRefCount(objv[objc]); - } - TclStackFree(interp, objv); - if (TCL_ERROR == status) { - /* - * Something was bogus in the return options. Clear the error message, - * and report back to the compiler that this must be interpreted at - * runtime. - */ - - Tcl_ResetResult(interp); - return TCL_ERROR; - } - - /* - * All options are known at compile time, so we're going to bytecompile. - * Emit instructions to push the result on the stack. - */ - - if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords-1); - } else { - /* - * No explict result argument, so default result is empty string. - */ - - PushLiteral(envPtr, "", 0); - } - - /* - * Check for optimization: When [return] is in a proc, and there's no - * enclosing [catch], and there are no return options, then the INST_DONE - * instruction is equivalent, and may be more efficient. - */ - - if (numOptionWords == 0 && envPtr->procPtr != NULL) { - /* - * We have default return options and we're in a proc ... - */ - - int index = envPtr->exceptArrayNext - 1; - int enclosingCatch = 0; - - while (index >= 0) { - ExceptionRange range = envPtr->exceptArrayPtr[index]; - - if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == -1)) { - enclosingCatch = 1; - break; - } - index--; - } - if (!enclosingCatch) { - /* - * ... and there is no enclosing catch. Issue the maximally - * efficient exit instruction. - */ - - Tcl_DecrRefCount(returnOpts); - TclEmitOpcode(INST_DONE, envPtr); - envPtr->currStackDepth = savedStackDepth; - return TCL_OK; - } - } - - /* Optimize [return -level 0 $x]. */ - Tcl_DictObjSize(NULL, returnOpts, &size); - if (size == 0 && level == 0 && code == TCL_OK) { - Tcl_DecrRefCount(returnOpts); - return TCL_OK; - } - - /* - * Could not use the optimization, so we push the return options dict, and - * emit the INST_RETURN_IMM instruction with code and level as operands. - */ - - CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; - - issueRuntimeReturn: - /* - * Assemble the option dictionary (as a list as that's good enough). - */ - - wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (objc=1 ; objc<=numOptionWords ; objc++) { - CompileWord(envPtr, wordTokenPtr, interp, objc); - wordTokenPtr = TokenAfter(wordTokenPtr); - } - TclEmitInstInt4(INST_LIST, numOptionWords, envPtr); - - /* - * Push the result. - */ - - if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords-1); - } else { - PushLiteral(envPtr, "", 0); - } - - /* - * Issue the RETURN itself. - */ - - TclEmitOpcode(INST_RETURN_STK, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; -} - -static void -CompileReturnInternal( - CompileEnv *envPtr, - unsigned char op, - int code, - int level, - Tcl_Obj *returnOpts) -{ - TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); - TclEmitInstInt4(op, code, envPtr); - TclEmitInt4(level, envPtr); -} - -void -TclCompileSyntaxError( - Tcl_Interp *interp, - CompileEnv *envPtr) -{ - Tcl_Obj *msg = Tcl_GetObjResult(interp); - int numBytes; - const char *bytes = TclGetStringFromObj(msg, &numBytes); - - TclErrorStackResetIf(interp, bytes, numBytes); - TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); - CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, - TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileUpvarCmd -- - * - * Procedure called to compile the "upvar" 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 "upvar" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileUpvarCmd( - 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, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr = Tcl_NewObj(); - - if (envPtr->procPtr == NULL) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - if (numWords < 3) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - /* - * Push the frame index if it is known at compile time - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - CallFrame *framePtr; - const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; - - /* - * Attempt to convert to a level reference. Note that TclObjGetFrame - * only changes the obj type when a conversion was successful. - */ - - TclObjGetFrame(interp, objPtr, &framePtr); - newTypePtr = objPtr->typePtr; - Tcl_DecrRefCount(objPtr); - - if (newTypePtr != typePtr) { - if (numWords%2) { - return TCL_ERROR; - } - CompileWord(envPtr, tokenPtr, interp, 1); - otherTokenPtr = TokenAfter(tokenPtr); - i = 4; - } else { - if (!(numWords%2)) { - return TCL_ERROR; - } - PushLiteral(envPtr, "1", 1); - otherTokenPtr = tokenPtr; - i = 3; - } - } else { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - /* - * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a - * local variable, return an error so that the non-compiled command will - * be called at runtime. - */ - - for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { - localTokenPtr = TokenAfter(otherTokenPtr); - - CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - if ((localIndex < 0) || !isScalar) { - return TCL_ERROR; - } - TclEmitInstInt4( INST_UPVAR, localIndex, envPtr); - } - - /* - * Pop the frame index, and set the result to empty - */ - - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileVariableCmd -- - * - * Procedure called to compile the "variable" 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 "variable" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileVariableCmd( - 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 *varTokenPtr, *valueTokenPtr; - int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords; - if (numWords < 2) { - return TCL_ERROR; - } - - /* - * Bail out if not compiling a proc body - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Loop over the (var, value) pairs. - */ - - valueTokenPtr = parsePtr->tokenPtr; - for (i=1; inumComponents; - Tcl_Token *lastTokenPtr; - int full, localIndex; - - /* - * Determine if the tail is (a) known at compile time, and (b) not an - * array element. Should any of these fail, return an error so that the - * non-compiled command will be called at runtime. - * - * In order for the tail to be known at compile time, the last token in - * the word has to be constant and contain "::" if it is not the only one. - */ - - if (!EnvHasLVT(envPtr)) { - return -1; - } - - TclNewObj(tailPtr); - if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { - full = 1; - lastTokenPtr = varTokenPtr; - } else { - full = 0; - lastTokenPtr = varTokenPtr + n; - if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { - Tcl_DecrRefCount(tailPtr); - return -1; - } - } - - tailName = TclGetStringFromObj(tailPtr, &len); - - if (len) { - if (*(tailName+len-1) == ')') { - /* - * Possible array: bail out - */ - - Tcl_DecrRefCount(tailPtr); - return -1; - } - - /* - * Get the tail: immediately after the last '::' - */ - - for (p = tailName + len -1; p > tailName; p--) { - if ((*p == ':') && (*(p-1) == ':')) { - p++; - break; - } - } - if (!full && (p == tailName)) { - /* - * No :: in the last component. - */ - - Tcl_DecrRefCount(tailPtr); - return -1; - } - len -= p - tailName; - tailName = p; - } - - localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr); - Tcl_DecrRefCount(tailPtr); - return localIndex; -} - -int -TclCompileObjectSelfCmd( - 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. */ -{ - /* - * We only handle [self] and [self object] (which is the same operation). - * These are the only very common operations on [self] for which - * bytecoding is at all reasonable. - */ - - if (parsePtr->numWords == 1) { - goto compileSelfObject; - } else if (parsePtr->numWords == 2) { - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { - return TCL_ERROR; - } - - subcmd = tokenPtr + 1; - if (strncmp(subcmd->start, "object", subcmd->size) == 0) { - goto compileSelfObject; - } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { - goto compileSelfNamespace; - } - } - - /* - * Can't compile; handle with runtime call. - */ - - return TCL_ERROR; - - compileSelfObject: - - /* - * This delegates the entire problem to a single opcode. - */ - - TclEmitOpcode( INST_TCLOO_SELF, envPtr); - return TCL_OK; - - compileSelfNamespace: - - /* - * This is formally only correct with TclOO methods as they are currently - * implemented; it assumes that the current namespace is invariably when a - * TclOO context is present is the object's namespace, and that's - * technically only something that's a matter of current policy. But it - * avoids creating another opcode, so that's all good! - */ - - TclEmitOpcode( INST_TCLOO_SELF, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_NS_CURRENT, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * PushVarName -- * * Procedure used in the compiling where pushing a variable name is diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c new file mode 100644 index 0000000..83a84e8 --- /dev/null +++ b/generic/tclCompCmdsGR.c @@ -0,0 +1,3244 @@ +/* + * tclCompCmdsGR.c -- + * + * This file contains compilation procedures that compile various Tcl + * commands (beginning with the letters 'g' through 'r') into a sequence + * of instructions ("bytecodes"). + * + * Copyright (c) 1997-1998 Sun Microsystems, Inc. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2002 ActiveState Corporation. + * Copyright (c) 2004-2013 by Donal K. Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include + +/* + * Prototypes for procedures defined later in this file: + */ + +static void CompileReturnInternal(CompileEnv *envPtr, + unsigned char op, int code, int level, + Tcl_Obj *returnOpts); +static int IndexTailVarIfKnown(Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr); +static int PushVarName(Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr, + int flags, int *localIndexPtr, + int *simpleVarNamePtr, int *isScalarPtr, + int line, int *clNext); +static int CompileEachloopCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + CompileEnv *envPtr, int collect); +static int CompileDictEachCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr, int collect); + + +/* + * Macro that encapsulates an efficiency trick that avoids a function call for + * the simplest of compiles. The ANSI C "prototype" for this macro is: + * + * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp, int word); + */ + +#define CompileWord(envPtr, tokenPtr, interp, word) \ + if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ + TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ + (tokenPtr)[1].size), (envPtr)); \ + } else { \ + envPtr->line = mapPtr->loc[eclIndex].line[word]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ + TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)); \ + } + +/* + * TIP #280: Remember the per-word line information of the current command. An + * index is used instead of a pointer as recursive compilation may reallocate, + * i.e. move, the array. This is also the reason to save the nuloc now, it may + * change during the course of the function. + * + * Macro to encapsulate the variable definition and setup. + */ + +#define DefineLineInformation \ + ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ + int eclIndex = mapPtr->nuloc - 1 + +#define SetLineInformation(word) \ + envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] + +#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ + PushVarName(i,v,e,f,l,s,sc, \ + mapPtr->loc[eclIndex].line[(word)], \ + mapPtr->loc[eclIndex].next[(word)]) + +/* + * Often want to issue one of two versions of an instruction based on whether + * the argument will fit in a single byte or not. This makes it much clearer. + */ + +#define Emit14Inst(nm,idx,envPtr) \ + if (idx <= 255) { \ + TclEmitInstInt1(nm##1,idx,envPtr); \ + } else { \ + TclEmitInstInt4(nm##4,idx,envPtr); \ + } + +/* + * Flags bits used by PushVarName. + */ + +#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ +#define TCL_NO_ELEMENT 2 /* Do not push the array element. */ + +/* + *---------------------------------------------------------------------- + * + * TclCompileGlobalCmd -- + * + * Procedure called to compile the "global" 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 "global" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileGlobalCmd( + 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 *varTokenPtr; + int localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + if (numWords < 2) { + return TCL_ERROR; + } + + /* + * 'global' has no effect outside of proc bodies; handle that at runtime + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Push the namespace + */ + + PushLiteral(envPtr, "::", 2); + + /* + * Loop over the variables. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { + localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); + + if (localIndex < 0) { + return TCL_ERROR; + } + + CompileWord(envPtr, varTokenPtr, interp, 1); + TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); + } + + /* + * Pop the namespace, and set the result to empty + */ + + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIfCmd -- + * + * Procedure called to compile the "if" 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 "if" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIfCmd( + 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. */ +{ + JumpFixupArray jumpFalseFixupArray; + /* Used to fix the ifFalse jump after each + * test when its target PC is determined. */ + JumpFixupArray jumpEndFixupArray; + /* Used to fix the jump after each "then" body + * to the end of the "if" when that PC is + * determined. */ + Tcl_Token *tokenPtr, *testTokenPtr; + int jumpIndex = 0; /* Avoid compiler warning. */ + int jumpFalseDist, numWords, wordIdx, numBytes, j, code; + const char *word; + int savedStackDepth = envPtr->currStackDepth; + /* Saved stack depth at the start of the first + * test; the envPtr current depth is restored + * to this value at the start of each test. */ + int realCond = 1; /* Set to 0 for static conditions: + * "if 0 {..}" */ + int boolVal; /* Value of static condition. */ + int compileScripts = 1; + DefineLineInformation; /* TIP #280 */ + + /* + * Only compile the "if" command if all arguments are simple words, in + * order to insure correct substitution [Bug 219166] + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + numWords = parsePtr->numWords; + + for (wordIdx = 0; wordIdx < numWords; wordIdx++) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + } + + TclInitJumpFixupArray(&jumpFalseFixupArray); + TclInitJumpFixupArray(&jumpEndFixupArray); + code = TCL_OK; + + /* + * Each iteration of this loop compiles one "if expr ?then? body" or + * "elseif expr ?then? body" clause. + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + while (wordIdx < numWords) { + /* + * Stop looping if the token isn't "if" or "elseif". + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((tokenPtr == parsePtr->tokenPtr) + || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + } else { + break; + } + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + + /* + * Compile the test expression then emit the conditional jump around + * the "then" part. + */ + + envPtr->currStackDepth = savedStackDepth; + testTokenPtr = tokenPtr; + + if (realCond) { + /* + * Find out if the condition is a constant. + */ + + Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, + testTokenPtr[1].size); + + Tcl_IncrRefCount(boolObj); + code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); + TclDecrRefCount(boolObj); + if (code == TCL_OK) { + /* + * A static condition. + */ + + realCond = 0; + if (!boolVal) { + compileScripts = 0; + } + } else { + SetLineInformation(wordIdx); + Tcl_ResetResult(interp); + TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { + TclExpandJumpFixupArray(&jumpFalseFixupArray); + } + jumpIndex = jumpFalseFixupArray.next; + jumpFalseFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + jumpFalseFixupArray.fixup+jumpIndex); + } + code = TCL_OK; + } + + /* + * Skip over the optional "then" before the then clause. + */ + + tokenPtr = TokenAfter(testTokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + } + } + + /* + * Compile the "then" command body. + */ + + if (compileScripts) { + SetLineInformation(wordIdx); + envPtr->currStackDepth = savedStackDepth; + CompileBody(envPtr, tokenPtr, interp); + } + + if (realCond) { + /* + * Jump to the end of the "if" command. Both jumpFalseFixupArray + * and jumpEndFixupArray are indexed by "jumpIndex". + */ + + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { + TclExpandJumpFixupArray(&jumpEndFixupArray); + } + jumpEndFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + jumpEndFixupArray.fixup+jumpIndex); + + /* + * Fix the target of the jumpFalse after the test. Generate a 4 + * byte jump if the distance is > 120 bytes. This is conservative, + * and ensures that we won't have to replace this jump if we later + * also need to replace the proceeding jump to the end of the "if" + * with a 4 byte jump. + */ + + if (TclFixupForwardJumpToHere(envPtr, + jumpFalseFixupArray.fixup+jumpIndex, 120)) { + /* + * Adjust the code offset for the proceeding jump to the end + * of the "if" command. + */ + + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + } + } else if (boolVal) { + /* + * We were processing an "if 1 {...}"; stop compiling scripts. + */ + + compileScripts = 0; + } else { + /* + * We were processing an "if 0 {...}"; reset so that the rest + * (elseif, else) is compiled correctly. + */ + + realCond = 1; + compileScripts = 1; + } + + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + } + + /* + * Restore the current stack depth in the environment; the "else" clause + * (or its default) will add 1 to this. + */ + + envPtr->currStackDepth = savedStackDepth; + + /* + * Check for the optional else clause. Do not compile anything if this was + * an "if 1 {...}" case. + */ + + if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + /* + * There is an else clause. Skip over the optional "else" word. + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + } + + if (compileScripts) { + /* + * Compile the else command body. + */ + + SetLineInformation(wordIdx); + CompileBody(envPtr, tokenPtr, interp); + } + + /* + * Make sure there are no words after the else clause. + */ + + wordIdx++; + if (wordIdx < numWords) { + code = TCL_ERROR; + goto done; + } + } else { + /* + * No else clause: the "if" command's result is an empty string. + */ + + if (compileScripts) { + PushLiteral(envPtr, "", 0); + } + } + + /* + * Fix the unconditional jumps to the end of the "if" command. + */ + + for (j = jumpEndFixupArray.next; j > 0; j--) { + jumpIndex = (j - 1); /* i.e. process the closest jump first. */ + if (TclFixupForwardJumpToHere(envPtr, + jumpEndFixupArray.fixup+jumpIndex, 127)) { + /* + * Adjust the immediately preceeding "ifFalse" jump. We moved it's + * target (just after this jump) down three bytes. + */ + + unsigned char *ifFalsePc = envPtr->codeStart + + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + unsigned char opCode = *ifFalsePc; + + if (opCode == INST_JUMP_FALSE1) { + jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else if (opCode == INST_JUMP_FALSE4) { + jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else { + Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); + } + } + } + + /* + * Free the jumpFixupArray array if malloc'ed storage was used. + */ + + done: + envPtr->currStackDepth = savedStackDepth + 1; + TclFreeJumpFixupArray(&jumpFalseFixupArray); + TclFreeJumpFixupArray(&jumpEndFixupArray); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIncrCmd -- + * + * Procedure called to compile the "incr" 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 "incr" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIncrCmd( + 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 *varTokenPtr, *incrTokenPtr; + int simpleVarName, isScalar, localIndex, haveImmValue, immValue; + DefineLineInformation; /* TIP #280 */ + + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + return TCL_ERROR; + } + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, + &localIndex, &simpleVarName, &isScalar, 1); + + /* + * If an increment is given, push it, but see first if it's a small + * integer. + */ + + haveImmValue = 0; + immValue = 1; + if (parsePtr->numWords == 3) { + incrTokenPtr = TokenAfter(varTokenPtr); + if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + const char *word = incrTokenPtr[1].start; + int numBytes = incrTokenPtr[1].size; + int code; + Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); + + Tcl_IncrRefCount(intObj); + code = TclGetIntFromObj(NULL, intObj, &immValue); + TclDecrRefCount(intObj); + if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { + haveImmValue = 1; + } + if (!haveImmValue) { + PushLiteral(envPtr, word, numBytes); + } + } else { + SetLineInformation(2); + CompileTokens(envPtr, incrTokenPtr, interp); + } + } else { /* No incr amount given so use 1. */ + haveImmValue = 1; + } + + /* + * Emit the instruction to increment the variable. + */ + + if (!simpleVarName) { + if (haveImmValue) { + TclEmitInstInt1( INST_INCR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode( INST_INCR_STK, envPtr); + } + } else if (isScalar) { /* Simple scalar variable. */ + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode( INST_INCR_SCALAR_STK, envPtr); + } + } + } else { /* Simple array variable. */ + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr); + } + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileInfo*Cmd -- + * + * Procedures called to compile "info" subcommands. + * + * 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 "info" subcommand at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileInfoCommandsCmd( + 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) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + char *bytes; + + /* + * We require one compile-time known argument for the case we can compile. + */ + + if (parsePtr->numWords == 1) { + return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } else if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + goto notCompilable; + } + bytes = Tcl_GetString(objPtr); + + /* + * We require that the argument start with "::" and not have any of "*\[?" + * in it. (Theoretically, we should look in only the final component, but + * the difference is so slight given current naming practices.) + */ + + if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) { + goto notCompilable; + } + Tcl_DecrRefCount(objPtr); + + /* + * Confirmed as a literal that will not frighten the horses. Compile. Note + * that the result needs to be list-ified. + */ + + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_STR_LEN, envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); + TclEmitInstInt4( INST_LIST, 1, envPtr); + return TCL_OK; + + notCompilable: + Tcl_DecrRefCount(objPtr); + return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileInfoCoroutineCmd( + 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. */ +{ + /* + * Only compile [info coroutine] without arguments. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_COROUTINE_NAME, envPtr); + return TCL_OK; +} + +int +TclCompileInfoExistsCmd( + 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; + int isScalar, simpleVarName, localIndex; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, + &simpleVarName, &isScalar, 1); + + /* + * Emit instruction to check the variable for existence. + */ + + if (!simpleVarName) { + TclEmitOpcode( INST_EXIST_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_EXIST_STK, envPtr); + } else { + TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr); + } else { + TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); + } + } + + return TCL_OK; +} + +int +TclCompileInfoLevelCmd( + 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. */ +{ + /* + * Only compile [info level] without arguments or with a single argument. + */ + + if (parsePtr->numWords == 1) { + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); + } else if (parsePtr->numWords != 2) { + return TCL_ERROR; + } else { + DefineLineInformation; /* TIP #280 */ + + /* + * Compile the argument, then add the instruction to convert it into a + * list of arguments. + */ + + SetLineInformation(1); + CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); + TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); + } + return TCL_OK; +} + +int +TclCompileInfoObjectClassCmd( + 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) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_TCLOO_CLASS, envPtr); + return TCL_OK; +} + +int +TclCompileInfoObjectIsACmd( + 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) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * We only handle [info object isa object ]. The first three + * words are compressed to a single token by the ensemble compilation + * engine. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 + || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + + /* + * Issue the code. + */ + + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); + return TCL_OK; +} + +int +TclCompileInfoObjectNamespaceCmd( + 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) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_TCLOO_NS, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLappendCmd -- + * + * Procedure called to compile the "lappend" 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 "lappend" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLappendCmd( + 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 *varTokenPtr, *valueTokenPtr; + int simpleVarName, isScalar, localIndex, numWords, i, fwd, offsetFwd; + DefineLineInformation; /* TIP #280 */ + + /* + * If we're not in a procedure, don't compile. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + numWords = parsePtr->numWords; + if (numWords == 1) { + return TCL_ERROR; + } + if (numWords != 3) { + /* + * LAPPEND instructions currently only handle one value, but we can + * handle some multi-value cases by stringing them together. + */ + + goto lappendMultiple; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + + /* + * If we are doing an assignment, push the new value. In the no values + * case, create an empty object. + */ + + if (numWords > 2) { + Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); + + CompileWord(envPtr, valueTokenPtr, interp, 2); + } + + /* + * Emit instructions to set/get the variable. + */ + + /* + * The *_STK opcodes should be refactored to make better use of existing + * LOAD/STORE instructions. + */ + + if (!simpleVarName) { + TclEmitOpcode( INST_LAPPEND_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_STK, envPtr); + } else { + Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); + } else { + Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); + } + } + + return TCL_OK; + + lappendMultiple: + /* + * Can only handle the case where we are appending to a local scalar when + * there are multiple values to append. Fortunately, this is common. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar || localIndex < 0) { + return TCL_ERROR; + } + + /* + * Definitely appending to a local scalar; generate the words and append + * them. + */ + + valueTokenPtr = TokenAfter(varTokenPtr); + for (i = 2 ; i < numWords ; i++) { + CompileWord(envPtr, valueTokenPtr, interp, i); + valueTokenPtr = TokenAfter(valueTokenPtr); + } + TclEmitInstInt4( INST_LIST, numWords-2, envPtr); + TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLassignCmd -- + * + * Procedure called to compile the "lassign" 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 "lassign" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLassignCmd( + 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; + int simpleVarName, isScalar, localIndex, numWords, idx; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + + /* + * Check for command syntax error, but we'll punt that to runtime. + */ + + if (numWords < 3) { + return TCL_ERROR; + } + + /* + * Generate code to push list being taken apart by [lassign]. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Generate code to assign values from the list to variables. + */ + + for (idx=0 ; idx= 0) { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } else { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + } else { + if (localIndex >= 0) { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } else { + TclEmitInstInt4(INST_OVER, 2, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + } + } + + /* + * Generate code to leave the rest of the list on the stack. + */ + + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4( -2 /* == "end" */, envPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLindexCmd -- + * + * Procedure called to compile the "lindex" 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 "lindex" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLindexCmd( + 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 *idxTokenPtr, *valTokenPtr; + int i, numWords = parsePtr->numWords; + DefineLineInformation; /* TIP #280 */ + + /* + * Quit if too few args. + */ + + if (numWords <= 1) { + return TCL_ERROR; + } + + valTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (numWords != 3) { + goto emitComplexLindex; + } + + 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 the conversion failed or the value was negative, we just keep on + * going with the more complex compilation. + */ + } + + /* + * Push the operands onto the stack. + */ + + emitComplexLindex: + for (i=1 ; inumWords == 1) { + /* + * [list] without arguments just pushes an empty object. + */ + + PushLiteral(envPtr, "", 0); + return TCL_OK; + } + + /* + * Test if all arguments are compile-time known. If they are, we can + * implement with a simple push. + */ + + numWords = parsePtr->numWords; + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + listObj = Tcl_NewObj(); + for (i = 1; i < numWords && listObj != NULL; i++) { + objPtr = Tcl_NewObj(); + if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) { + (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); + } else { + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(listObj); + listObj = NULL; + } + valueTokenPtr = TokenAfter(valueTokenPtr); + } + if (listObj != NULL) { + int len; + const char *bytes = Tcl_GetStringFromObj(listObj, &len); + + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(listObj); + if (len > 0) { + /* + * Force list interpretation! + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + return TCL_OK; + } + + /* + * Push the all values onto the stack. + */ + + numWords = parsePtr->numWords; + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + concat = build = 0; + for (i = 1; i < numWords; i++) { + if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { + TclEmitInstInt4( INST_LIST, build, envPtr); + if (concat) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } + build = 0; + concat = 1; + } + CompileWord(envPtr, valueTokenPtr, interp, i); + if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + if (concat) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } else { + concat = 1; + } + } else { + build++; + } + valueTokenPtr = TokenAfter(valueTokenPtr); + } + if (build > 0) { + TclEmitInstInt4( INST_LIST, build, envPtr); + if (concat) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } + } + + /* + * If there was just one expanded word, we must ensure that it is a list + * at this point. We use an [lrange ... 0 end] for this (instead of + * [llength], as with literals) as we must drop any string representation + * that might be hanging around. + */ + + if (concat && numWords == 2) { + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( -2, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLlengthCmd -- + * + * Procedure called to compile the "llength" 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 "llength" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLlengthCmd( + 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 *varTokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, varTokenPtr, interp, 1); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLrangeCmd -- + * + * How to compile the "lrange" command. We only bother because we needed + * the opcode anyway for "lassign". + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLrangeCmd( + 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, result; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * 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). + */ + + tokenPtr = TokenAfter(listTokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + 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) { + return TCL_ERROR; + } + + /* + * 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. + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLreplaceCmd -- + * + * 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".) + * + *---------------------------------------------------------------------- + */ + +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, result, guaranteedDropAll = 0; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * 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). + */ + + tokenPtr = TokenAfter(listTokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + 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) { + return TCL_ERROR; + } + + /* + * 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]. + */ + + if (idx1 == 0) { + if (idx2 == -2) { + guaranteedDropAll = 1; + } + idx1 = idx2 + 1; + idx2 = -2; + } else if (idx2 == -2) { + idx2 = idx1 - 1; + idx1 = 0; + } else { + return TCL_ERROR; + } + + /* + * 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. + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + if (guaranteedDropAll) { + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + } else { + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLsetCmd -- + * + * Procedure called to compile the "lset" 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 "lset" command at + * runtime. + * + * The general template for execution of the "lset" command is: + * (1) Instructions to push the variable name, unless the variable is + * local to the stack frame. + * (2) If the variable is an array element, instructions to push the + * array element name. + * (3) Instructions to push each of zero or more "index" arguments to the + * stack, followed with the "newValue" element. + * (4) Instructions to duplicate the variable name and/or array element + * name onto the top of the stack, if either was pushed at steps (1) + * and (2). + * (5) The appropriate INST_LOAD_* instruction to place the original + * value of the list variable at top of stack. + * (6) At this point, the stack contains: + * varName? arrayElementName? index1 index2 ... newValue oldList + * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST + * according as whether there is exactly one index element (LIST) or + * either zero or else two or more (FLAT). This instruction removes + * everything from the stack except for the two names and pushes the + * new value of the variable. + * (7) Finally, INST_STORE_* stores the new value in the variable and + * cleans up the stack. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLsetCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + 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. */ +{ + int tempDepth; /* Depth used for emitting one part of the + * code burst. */ + Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the + * parse of the variable name. */ + int localIndex; /* Index of var in local var table. */ + int simpleVarName; /* Flag == 1 if var name is simple. */ + int isScalar; /* Flag == 1 if scalar, 0 if array. */ + int i; + DefineLineInformation; /* TIP #280 */ + + /* + * Check argument count. + */ + + if (parsePtr->numWords < 3) { + /* + * Fail at run time, not in compilation. + */ + + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + + /* + * Push the "index" args and the new element value. + */ + + for (i=2 ; inumWords ; ++i) { + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp, i); + } + + /* + * Duplicate the variable name if it's been pushed. + */ + + if (!simpleVarName || localIndex < 0) { + if (!simpleVarName || isScalar) { + tempDepth = parsePtr->numWords - 2; + } else { + tempDepth = parsePtr->numWords - 1; + } + TclEmitInstInt4( INST_OVER, tempDepth, envPtr); + } + + /* + * Duplicate an array index if one's been pushed. + */ + + if (simpleVarName && !isScalar) { + if (localIndex < 0) { + tempDepth = parsePtr->numWords - 1; + } else { + tempDepth = parsePtr->numWords - 2; + } + TclEmitInstInt4( INST_OVER, tempDepth, envPtr); + } + + /* + * Emit code to load the variable's value. + */ + + if (!simpleVarName) { + TclEmitOpcode( INST_LOAD_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr); + } else { + Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); + } else { + Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); + } + } + + /* + * Emit the correct variety of 'lset' instruction. + */ + + if (parsePtr->numWords == 4) { + TclEmitOpcode( INST_LSET_LIST, envPtr); + } else { + TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); + } + + /* + * Emit code to put the value back in the variable. + */ + + if (!simpleVarName) { + TclEmitOpcode( INST_STORE_STK, envPtr); + } else if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); + } else { + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + } else { + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileNamespace*Cmd -- + * + * Procedures called to compile the "namespace" command; currently, only + * the subcommands "namespace current" and "namespace upvar" are compiled + * to bytecodes, and the latter only inside a procedure(-like) context. + * + * 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 "namespace upvar" + * command at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileNamespaceCurrentCmd( + 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. */ +{ + /* + * Only compile [namespace current] without arguments. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_NS_CURRENT, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceCodeCmd( + 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); + + /* + * The specification of [namespace code] is rather shocking, in that it is + * supposed to check if the argument is itself the result of [namespace + * code] and not apply itself in that case. Which is excessively cautious, + * but what the test suite checks for. + */ + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20 + && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) { + /* + * Technically, we could just pass a literal '::namespace inscope ' + * term through, but that's something which really shouldn't be + * occurring as something that the user writes so we'll just punt it. + */ + + return TCL_ERROR; + } + + /* + * Now we can compile using the same strategy as [namespace code]'s normal + * implementation does internally. Note that we can't bind the namespace + * name directly here, because TclOO plays complex games with namespaces; + * the value needs to be determined at runtime for safety. + */ + + PushLiteral(envPtr, "::namespace", 11); + PushLiteral(envPtr, "inscope", 7); + TclEmitOpcode( INST_NS_CURRENT, envPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST, 4, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceQualifiersCmd( + 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 = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + int off; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + CompileWord(envPtr, tokenPtr, interp, 1); + PushLiteral(envPtr, "0", 1); + PushLiteral(envPtr, "::", 2); + TclEmitInstInt4( INST_OVER, 2, envPtr); + TclEmitOpcode( INST_STR_FIND_LAST, envPtr); + off = CurrentOffset(envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitOpcode( INST_SUB, envPtr); + TclEmitInstInt4( INST_OVER, 2, envPtr); + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitOpcode( INST_STR_INDEX, envPtr); + PushLiteral(envPtr, ":", 1); + TclEmitOpcode( INST_STR_EQ, envPtr); + off = off - CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); + TclEmitOpcode( INST_STR_RANGE, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceTailCmd( + 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 = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + JumpFixup jumpFixup; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + /* + * Take care; only add 2 to found index if the string was actually found. + */ + + CompileWord(envPtr, tokenPtr, interp, 1); + PushLiteral(envPtr, "::", 2); + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitOpcode( INST_STR_FIND_LAST, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + PushLiteral(envPtr, "0", 1); + TclEmitOpcode( INST_GE, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); + PushLiteral(envPtr, "2", 1); + TclEmitOpcode( INST_ADD, envPtr); + TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + PushLiteral(envPtr, "end", 3); + TclEmitOpcode( INST_STR_RANGE, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceUpvarCmd( + 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, *otherTokenPtr, *localTokenPtr; + int simpleVarName, isScalar, localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Only compile [namespace upvar ...]: needs an even number of args, >=4 + */ + + numWords = parsePtr->numWords; + if ((numWords % 2) || (numWords < 4)) { + return TCL_ERROR; + } + + /* + * Push the namespace + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a + * local variable, return an error so that the non-compiled command will + * be called at runtime. + */ + + localTokenPtr = tokenPtr; + for (i=3; i<=numWords; i+=2) { + otherTokenPtr = TokenAfter(localTokenPtr); + localTokenPtr = TokenAfter(otherTokenPtr); + + CompileWord(envPtr, otherTokenPtr, interp, 1); + PushVarNameWord(interp, localTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + + if ((localIndex < 0) || !isScalar) { + return TCL_ERROR; + } + TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); + } + + /* + * Pop the namespace, and set the result to empty + */ + + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +int +TclCompileNamespaceWhichCmd( + 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, *opt; + int idx; + + if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + idx = 1; + + /* + * If there's an option, check that it's "-command". We don't handle + * "-variable" (currently) and anything else is an error. + */ + + if (parsePtr->numWords == 3) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + opt = tokenPtr + 1; + if (opt->size < 2 || opt->size > 8 + || strncmp(opt->start, "-command", opt->size) != 0) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + idx++; + } + + /* + * Issue the bytecode. + */ + + CompileWord(envPtr, tokenPtr, interp, idx); + TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileRegexpCmd -- + * + * Procedure called to compile the "regexp" 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 "regexp" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileRegexpCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + 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 *varTokenPtr; /* Pointer to the Tcl_Token representing the + * parse of the RE or string. */ + int i, len, nocase, exact, sawLast, simple; + const char *str; + DefineLineInformation; /* TIP #280 */ + + /* + * We are only interested in compiling simple regexp cases. Currently + * supported compile cases are: + * regexp ?-nocase? ?--? staticString $var + * regexp ?-nocase? ?--? {^staticString$} $var + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + simple = 0; + nocase = 0; + sawLast = 0; + varTokenPtr = parsePtr->tokenPtr; + + /* + * We only look for -nocase and -- as options. Everything else gets pushed + * to runtime execution. This is different than regexp's runtime option + * handling, but satisfies our stricter needs. + */ + + for (i = 1; i < parsePtr->numWords - 2; i++) { + varTokenPtr = TokenAfter(varTokenPtr); + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Not a simple string, so punt to runtime. + */ + + return TCL_ERROR; + } + str = varTokenPtr[1].start; + len = varTokenPtr[1].size; + if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { + sawLast++; + i++; + break; + } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { + nocase = 1; + } else { + /* + * Not an option we recognize. + */ + + return TCL_ERROR; + } + } + + if ((parsePtr->numWords - i) != 2) { + /* + * We don't support capturing to variables. + */ + + return TCL_ERROR; + } + + /* + * Get the regexp string. If it is not a simple string or can't be + * converted to a glob pattern, push the word for the INST_REGEXP. + * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. + */ + + varTokenPtr = TokenAfter(varTokenPtr); + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + Tcl_DString ds; + + str = varTokenPtr[1].start; + len = varTokenPtr[1].size; + + /* + * If it has a '-', it could be an incorrectly formed regexp command. + */ + + if ((*str == '-') && !sawLast) { + return TCL_ERROR; + } + + if (len == 0) { + /* + * The semantics of regexp are always match on re == "". + */ + + PushLiteral(envPtr, "1", 1); + return TCL_OK; + } + + /* + * Attempt to convert pattern to glob. If successful, push the + * converted pattern as a literal. + */ + + if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) + == TCL_OK) { + simple = 1; + PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + } + + if (!simple) { + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); + } + + /* + * Push the string arg. + */ + + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); + + if (simple) { + if (exact && !nocase) { + TclEmitOpcode( INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr); + } + } else { + /* + * Pass correct RE compile flags. We use only Int1 (8-bit), but + * that handles all the flags we want to pass. + * Don't use TCL_REG_NOSUB as we may have backrefs. + */ + + int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); + + TclEmitInstInt1( INST_REGEXP, cflags, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileRegsubCmd -- + * + * Procedure called to compile the "regsub" 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 "regsub" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileRegsubCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + 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. */ +{ + /* + * We only compile the case with [regsub -all] where the pattern is both + * known at compile time and simple (i.e., no RE metacharacters). That is, + * the pattern must be translatable into a glob like "*foo*" with no other + * glob metacharacters inside it; there must be some "foo" in there too. + * The substitution string must also be known at compile time and free of + * metacharacters ("\digit" and "&"). Finally, there must not be a + * variable mentioned in the [regsub] to write the result back to (because + * we can't get the count of substitutions that would be the result in + * that case). The key is that these are the conditions under which a + * [string map] could be used instead, in particular a [string map] of the + * form we can compile to bytecode. + * + * In short, we look for: + * + * regsub -all [--] simpleRE string simpleReplacement + * + * The only optional part is the "--", and no other options are handled. + */ + + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *stringTokenPtr; + Tcl_Obj *patternObj = NULL, *replacementObj = NULL; + Tcl_DString pattern; + const char *bytes; + int len, exact, result = TCL_ERROR; + + if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { + return TCL_ERROR; + } + + /* + * Parse the "-all", which must be the first argument (other options not + * supported, non-"-all" substitution we can't compile). + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4 + || strncmp(tokenPtr[1].start, "-all", 4)) { + return TCL_ERROR; + } + + /* + * Get the pattern into patternObj, checking for "--" in the process. + */ + + Tcl_DStringInit(&pattern); + tokenPtr = TokenAfter(tokenPtr); + patternObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { + goto done; + } + if (Tcl_GetString(patternObj)[0] == '-') { + if (strcmp(Tcl_GetString(patternObj), "--") != 0 + || parsePtr->numWords == 5) { + goto done; + } + tokenPtr = TokenAfter(tokenPtr); + Tcl_DecrRefCount(patternObj); + patternObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { + goto done; + } + } else if (parsePtr->numWords == 6) { + goto done; + } + + /* + * Identify the code which produces the string to apply the substitution + * to (stringTokenPtr), and the replacement string (into replacementObj). + */ + + stringTokenPtr = TokenAfter(tokenPtr); + tokenPtr = TokenAfter(stringTokenPtr); + replacementObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { + goto done; + } + + /* + * Next, higher-level checks. Is the RE a very simple glob? Is the + * replacement "simple"? + */ + + bytes = Tcl_GetStringFromObj(patternObj, &len); + if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { + goto done; + } + bytes = Tcl_DStringValue(&pattern); + if (*bytes++ != '*') { + goto done; + } + while (1) { + switch (*bytes) { + case '*': + if (bytes[1] == '\0') { + /* + * OK, we've proved there are no metacharacters except for the + * '*' at each end. + */ + + len = Tcl_DStringLength(&pattern) - 2; + if (len > 0) { + goto isSimpleGlob; + } + + /* + * The pattern is "**"! I believe that should be impossible, + * but we definitely can't handle that at all. + */ + } + case '\0': case '?': case '[': case '\\': + goto done; + } + bytes++; + } + isSimpleGlob: + for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { + switch (*bytes) { + case '\\': case '&': + goto done; + } + } + + /* + * Proved the simplicity constraints! Time to issue the code. + */ + + result = TCL_OK; + bytes = Tcl_DStringValue(&pattern) + 1; + PushLiteral(envPtr, bytes, len); + bytes = Tcl_GetStringFromObj(replacementObj, &len); + PushLiteral(envPtr, bytes, len); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); + TclEmitOpcode( INST_STR_MAP, envPtr); + + done: + Tcl_DStringFree(&pattern); + if (patternObj) { + Tcl_DecrRefCount(patternObj); + } + if (replacementObj) { + Tcl_DecrRefCount(replacementObj); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileReturnCmd -- + * + * Procedure called to compile the "return" 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 "return" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileReturnCmd( + 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. */ +{ + /* + * General syntax: [return ?-option value ...? ?result?] + * An even number of words means an explicit result argument is present. + */ + int level, code, objc, size, status = TCL_OK; + int numWords = parsePtr->numWords; + int explicitResult = (0 == (numWords % 2)); + int numOptionWords = numWords - 1 - explicitResult; + int savedStackDepth = envPtr->currStackDepth; + Tcl_Obj *returnOpts, **objv; + Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + + /* + * Check for special case which can always be compiled: + * return -options + * Unlike the normal [return] compilation, this version does everything at + * runtime so it can handle arbitrary words and not just literals. Note + * that if INST_RETURN_STK wasn't already needed for something else + * ('finally' clause processing) this piece of code would not be present. + */ + + if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) + && (wordTokenPtr[1].size == 8) + && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { + Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); + Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); + + CompileWord(envPtr, optsTokenPtr, interp, 2); + CompileWord(envPtr, msgTokenPtr, interp, 3); + TclEmitOpcode(INST_RETURN_STK, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; + return TCL_OK; + } + + /* + * Allocate some working space. + */ + + objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *)); + + /* + * Scan through the return options. If any are unknown at compile time, + * there is no value in bytecompiling. Save the option values known in an + * objv array for merging into a return options dictionary. + */ + + for (objc = 0; objc < numOptionWords; objc++) { + objv[objc] = Tcl_NewObj(); + Tcl_IncrRefCount(objv[objc]); + if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { + /* + * Non-literal, so punt to run-time. + */ + + for (; objc>=0 ; objc--) { + TclDecrRefCount(objv[objc]); + } + TclStackFree(interp, objv); + goto issueRuntimeReturn; + } + wordTokenPtr = TokenAfter(wordTokenPtr); + } + status = TclMergeReturnOptions(interp, objc, objv, + &returnOpts, &code, &level); + while (--objc >= 0) { + TclDecrRefCount(objv[objc]); + } + TclStackFree(interp, objv); + if (TCL_ERROR == status) { + /* + * Something was bogus in the return options. Clear the error message, + * and report back to the compiler that this must be interpreted at + * runtime. + */ + + Tcl_ResetResult(interp); + return TCL_ERROR; + } + + /* + * All options are known at compile time, so we're going to bytecompile. + * Emit instructions to push the result on the stack. + */ + + if (explicitResult) { + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + } else { + /* + * No explict result argument, so default result is empty string. + */ + + PushLiteral(envPtr, "", 0); + } + + /* + * Check for optimization: When [return] is in a proc, and there's no + * enclosing [catch], and there are no return options, then the INST_DONE + * instruction is equivalent, and may be more efficient. + */ + + if (numOptionWords == 0 && envPtr->procPtr != NULL) { + /* + * We have default return options and we're in a proc ... + */ + + int index = envPtr->exceptArrayNext - 1; + int enclosingCatch = 0; + + while (index >= 0) { + ExceptionRange range = envPtr->exceptArrayPtr[index]; + + if ((range.type == CATCH_EXCEPTION_RANGE) + && (range.catchOffset == -1)) { + enclosingCatch = 1; + break; + } + index--; + } + if (!enclosingCatch) { + /* + * ... and there is no enclosing catch. Issue the maximally + * efficient exit instruction. + */ + + Tcl_DecrRefCount(returnOpts); + TclEmitOpcode(INST_DONE, envPtr); + envPtr->currStackDepth = savedStackDepth; + return TCL_OK; + } + } + + /* Optimize [return -level 0 $x]. */ + Tcl_DictObjSize(NULL, returnOpts, &size); + if (size == 0 && level == 0 && code == TCL_OK) { + Tcl_DecrRefCount(returnOpts); + return TCL_OK; + } + + /* + * Could not use the optimization, so we push the return options dict, and + * emit the INST_RETURN_IMM instruction with code and level as operands. + */ + + CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); + envPtr->currStackDepth = savedStackDepth + 1; + return TCL_OK; + + issueRuntimeReturn: + /* + * Assemble the option dictionary (as a list as that's good enough). + */ + + wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (objc=1 ; objc<=numOptionWords ; objc++) { + CompileWord(envPtr, wordTokenPtr, interp, objc); + wordTokenPtr = TokenAfter(wordTokenPtr); + } + TclEmitInstInt4(INST_LIST, numOptionWords, envPtr); + + /* + * Push the result. + */ + + if (explicitResult) { + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + } else { + PushLiteral(envPtr, "", 0); + } + + /* + * Issue the RETURN itself. + */ + + TclEmitOpcode(INST_RETURN_STK, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; + return TCL_OK; +} + +static void +CompileReturnInternal( + CompileEnv *envPtr, + unsigned char op, + int code, + int level, + Tcl_Obj *returnOpts) +{ + TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); + TclEmitInstInt4(op, code, envPtr); + TclEmitInt4(level, envPtr); +} + +void +TclCompileSyntaxError( + Tcl_Interp *interp, + CompileEnv *envPtr) +{ + Tcl_Obj *msg = Tcl_GetObjResult(interp); + int numBytes; + const char *bytes = TclGetStringFromObj(msg, &numBytes); + + TclErrorStackResetIf(interp, bytes, numBytes); + TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); + CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, + TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileUpvarCmd -- + * + * Procedure called to compile the "upvar" 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 "upvar" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileUpvarCmd( + 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, *otherTokenPtr, *localTokenPtr; + int simpleVarName, isScalar, localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *objPtr = Tcl_NewObj(); + + if (envPtr->procPtr == NULL) { + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; + } + + numWords = parsePtr->numWords; + if (numWords < 3) { + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; + } + + /* + * Push the frame index if it is known at compile time + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + CallFrame *framePtr; + const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; + + /* + * Attempt to convert to a level reference. Note that TclObjGetFrame + * only changes the obj type when a conversion was successful. + */ + + TclObjGetFrame(interp, objPtr, &framePtr); + newTypePtr = objPtr->typePtr; + Tcl_DecrRefCount(objPtr); + + if (newTypePtr != typePtr) { + if (numWords%2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + otherTokenPtr = TokenAfter(tokenPtr); + i = 4; + } else { + if (!(numWords%2)) { + return TCL_ERROR; + } + PushLiteral(envPtr, "1", 1); + otherTokenPtr = tokenPtr; + i = 3; + } + } else { + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; + } + + /* + * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a + * local variable, return an error so that the non-compiled command will + * be called at runtime. + */ + + for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { + localTokenPtr = TokenAfter(otherTokenPtr); + + CompileWord(envPtr, otherTokenPtr, interp, 1); + PushVarNameWord(interp, localTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); + + if ((localIndex < 0) || !isScalar) { + return TCL_ERROR; + } + TclEmitInstInt4( INST_UPVAR, localIndex, envPtr); + } + + /* + * Pop the frame index, and set the result to empty + */ + + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "", 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileVariableCmd -- + * + * Procedure called to compile the "variable" 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 "variable" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileVariableCmd( + 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 *varTokenPtr, *valueTokenPtr; + int localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + if (numWords < 2) { + return TCL_ERROR; + } + + /* + * Bail out if not compiling a proc body + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Loop over the (var, value) pairs. + */ + + valueTokenPtr = parsePtr->tokenPtr; + for (i=1; inumComponents; + Tcl_Token *lastTokenPtr; + int full, localIndex; + + /* + * Determine if the tail is (a) known at compile time, and (b) not an + * array element. Should any of these fail, return an error so that the + * non-compiled command will be called at runtime. + * + * In order for the tail to be known at compile time, the last token in + * the word has to be constant and contain "::" if it is not the only one. + */ + + if (!EnvHasLVT(envPtr)) { + return -1; + } + + TclNewObj(tailPtr); + if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { + full = 1; + lastTokenPtr = varTokenPtr; + } else { + full = 0; + lastTokenPtr = varTokenPtr + n; + if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { + Tcl_DecrRefCount(tailPtr); + return -1; + } + } + + tailName = TclGetStringFromObj(tailPtr, &len); + + if (len) { + if (*(tailName+len-1) == ')') { + /* + * Possible array: bail out + */ + + Tcl_DecrRefCount(tailPtr); + return -1; + } + + /* + * Get the tail: immediately after the last '::' + */ + + for (p = tailName + len -1; p > tailName; p--) { + if ((*p == ':') && (*(p-1) == ':')) { + p++; + break; + } + } + if (!full && (p == tailName)) { + /* + * No :: in the last component. + */ + + Tcl_DecrRefCount(tailPtr); + return -1; + } + len -= p - tailName; + tailName = p; + } + + localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr); + Tcl_DecrRefCount(tailPtr); + return localIndex; +} + +int +TclCompileObjectSelfCmd( + 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. */ +{ + /* + * We only handle [self] and [self object] (which is the same operation). + * These are the only very common operations on [self] for which + * bytecoding is at all reasonable. + */ + + if (parsePtr->numWords == 1) { + goto compileSelfObject; + } else if (parsePtr->numWords == 2) { + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { + return TCL_ERROR; + } + + subcmd = tokenPtr + 1; + if (strncmp(subcmd->start, "object", subcmd->size) == 0) { + goto compileSelfObject; + } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { + goto compileSelfNamespace; + } + } + + /* + * Can't compile; handle with runtime call. + */ + + return TCL_ERROR; + + compileSelfObject: + + /* + * This delegates the entire problem to a single opcode. + */ + + TclEmitOpcode( INST_TCLOO_SELF, envPtr); + return TCL_OK; + + compileSelfNamespace: + + /* + * This is formally only correct with TclOO methods as they are currently + * implemented; it assumes that the current namespace is invariably when a + * TclOO context is present is the object's namespace, and that's + * technically only something that's a matter of current policy. But it + * avoids creating another opcode, so that's all good! + */ + + TclEmitOpcode( INST_TCLOO_SELF, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_NS_CURRENT, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PushVarName -- + * + * Procedure used in the compiling where pushing a variable name is + * necessary (append, lappend, set). + * + * 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 "set" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +static int +PushVarName( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Token *varTokenPtr, /* Points to a variable token. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ + int *localIndexPtr, /* Must not be NULL. */ + int *simpleVarNamePtr, /* Must not be NULL. */ + int *isScalarPtr, /* Must not be NULL. */ + int line, /* Line the token starts on. */ + int *clNext) /* Reference to offset of next hidden cont. + * line. */ +{ + register const char *p; + const char *name, *elName; + register int i, n; + Tcl_Token *elemTokenPtr = NULL; + int nameChars, elNameChars, simpleVarName, localIndex; + int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + simpleVarName = 0; + name = elName = NULL; + nameChars = elNameChars = 0; + localIndex = -1; + + /* + * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether + * curly braces surround the variable name. This really matters for array + * elements to handle things like + * set {x($foo)} 5 + * which raises an undefined var error if we are not careful here. + */ + + if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && + (varTokenPtr->start[0] != '{')) { + /* + * A simple variable name. Divide it up into "name" and "elName" + * strings. If it is not a local variable, look it up at runtime. + */ + + simpleVarName = 1; + + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + if (name[nameChars-1] == ')') { + /* + * last char is ')' => potential array reference. + */ + + for (i=0,p=name ; itype = TCL_TOKEN_TEXT; + elemTokenPtr->start = elName; + elemTokenPtr->size = elNameChars; + elemTokenPtr->numComponents = 0; + elemTokenCount = 1; + } + } + } else if (((n = varTokenPtr->numComponents) > 1) + && (varTokenPtr[1].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { + /* + * Check for parentheses inside first token. + */ + + simpleVarName = 0; + for (i = 0, p = varTokenPtr[1].start; + i < varTokenPtr[1].size; i++, p++) { + if (*p == '(') { + simpleVarName = 1; + break; + } + } + if (simpleVarName) { + int remainingChars; + + /* + * Check the last token: if it is just ')', do not count it. + * Otherwise, remove the ')' and flag so that it is restored at + * the end. + */ + + if (varTokenPtr[n].size == 1) { + n--; + } else { + varTokenPtr[n].size--; + removedParen = n; + } + + name = varTokenPtr[1].start; + nameChars = p - varTokenPtr[1].start; + elName = p + 1; + remainingChars = (varTokenPtr[2].start - p) - 1; + elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2; + + if (remainingChars) { + /* + * Make a first token with the extra characters in the first + * token. + */ + + elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); + allocedTokens = 1; + elemTokenPtr->type = TCL_TOKEN_TEXT; + elemTokenPtr->start = elName; + elemTokenPtr->size = remainingChars; + elemTokenPtr->numComponents = 0; + elemTokenCount = n; + + /* + * Copy the remaining tokens. + */ + + memcpy(elemTokenPtr+1, varTokenPtr+2, + (n-1) * sizeof(Tcl_Token)); + } else { + /* + * Use the already available tokens. + */ + + elemTokenPtr = &varTokenPtr[2]; + elemTokenCount = n - 1; + } + } + } + + if (simpleVarName) { + /* + * See whether name has any namespace separators (::'s). + */ + + int hasNsQualifiers = 0; + + for (i = 0, p = name; i < nameChars; i++, p++) { + if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { + hasNsQualifiers = 1; + break; + } + } + + /* + * Look up the var name's index in the array of local vars in the proc + * frame. If retrieving the var's value and it doesn't already exist, + * push its name and look it up at runtime. + */ + + if (!hasNsQualifiers) { + localIndex = TclFindCompiledLocal(name, nameChars, + 1, envPtr); + if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { + /* + * We'll push the name. + */ + + localIndex = -1; + } + } + if (localIndex < 0) { + PushLiteral(envPtr, name, nameChars); + } + + /* + * Compile the element script, if any, and only if not inhibited. [Bug + * 3600328] + */ + + if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { + if (elNameChars) { + envPtr->line = line; + envPtr->clNext = clNext; + TclCompileTokens(interp, elemTokenPtr, elemTokenCount, + envPtr); + } else { + PushLiteral(envPtr, "", 0); + } + } + } else { + /* + * The var name isn't simple: compile and push it. + */ + + envPtr->line = line; + envPtr->clNext = clNext; + CompileTokens(envPtr, varTokenPtr, interp); + } + + if (removedParen) { + varTokenPtr[removedParen].size++; + } + if (allocedTokens) { + TclStackFree(interp, elemTokenPtr); + } + *localIndexPtr = localIndex; + *simpleVarNamePtr = simpleVarName; + *isScalarPtr = (elName == NULL); + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/Makefile.in b/unix/Makefile.in index e0dc608..126fc03 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -291,9 +291,10 @@ XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ - tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \ - tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompCmdsSZ.o \ - tclCompExpr.o tclCompile.o tclConfig.o tclDate.o tclDictObj.o \ + tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ + tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ + tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \ + tclCompile.o tclConfig.o tclDate.o tclDictObj.o \ tclEncoding.o tclEnsemble.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ @@ -307,8 +308,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ - tclTomMathInterface.o \ - tclAssembly.o + tclTomMathInterface.o OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ tclOOMethod.o tclOOStubInit.o @@ -395,6 +395,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclCmdIL.c \ $(GENERIC_DIR)/tclCmdMZ.c \ $(GENERIC_DIR)/tclCompCmds.c \ + $(GENERIC_DIR)/tclCompCmdsGR.c \ $(GENERIC_DIR)/tclCompCmdsSZ.c \ $(GENERIC_DIR)/tclCompExpr.c \ $(GENERIC_DIR)/tclCompile.c \ @@ -1077,6 +1078,9 @@ tclDate.o: $(GENERIC_DIR)/tclDate.c tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c +tclCompCmdsGR.o: $(GENERIC_DIR)/tclCompCmdsGR.c $(COMPILEHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsGR.c + tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsSZ.c diff --git a/win/Makefile.in b/win/Makefile.in index 8b16372..3c9d276 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -225,6 +225,7 @@ GENERIC_OBJS = \ tclCmdIL.$(OBJEXT) \ tclCmdMZ.$(OBJEXT) \ tclCompCmds.$(OBJEXT) \ + tclCompCmdsGR.$(OBJEXT) \ tclCompCmdsSZ.$(OBJEXT) \ tclCompExpr.$(OBJEXT) \ tclCompile.$(OBJEXT) \ diff --git a/win/makefile.bc b/win/makefile.bc index 18bfa28..d148513 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -200,6 +200,7 @@ TCLOBJS = \ $(TMPDIR)\tclCmdIL.obj \ $(TMPDIR)\tclCmdMZ.obj \ $(TMPDIR)\tclCompCmds.obj \ + $(TMPDIR)\tclCompCmdsGR.obj \ $(TMPDIR)\tclCompCmdsSZ.obj \ $(TMPDIR)\tclCompExpr.obj \ $(TMPDIR)\tclCompile.obj \ diff --git a/win/makefile.vc b/win/makefile.vc index 2784140..95d3a9d 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -274,6 +274,7 @@ COREOBJS = \ $(TMP_DIR)\tclCmdIL.obj \ $(TMP_DIR)\tclCmdMZ.obj \ $(TMP_DIR)\tclCompCmds.obj \ + $(TMP_DIR)\tclCompCmdsGR.obj \ $(TMP_DIR)\tclCompCmdsSZ.obj \ $(TMP_DIR)\tclCompExpr.obj \ $(TMP_DIR)\tclCompile.obj \ -- cgit v0.12 From 0381a0636d9cf0732c403ff31d13a8585fffdbfd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 19 May 2013 13:36:42 +0000 Subject: Fix for FreeBSD, and remove support for older FreeBSD versions. Patch by Pietro Cerutti. --- ChangeLog | 5 + unix/configure | 799 ++++++++++++++++++++++++--------------------------------- unix/tcl.m4 | 47 +--- 3 files changed, 350 insertions(+), 501 deletions(-) diff --git a/ChangeLog b/ChangeLog index b38a105..ba702aa 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-05-19 Jan Nijtmans + + * unix/tcl.m4: Fix for FreeBSD, and remove support for older + * unix/configure: FreeBSD versions. Patch by Pietro Cerutti. + 2013-05-16 Jan Nijtmans * generic/tclBasic.c: Add panic in order to detect diff --git a/unix/configure b/unix/configure index 80d747c..ec5298c 100755 --- a/unix/configure +++ b/unix/configure @@ -3323,101 +3323,6 @@ EOF CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; - NetBSD-1.*|FreeBSD-[1-2].*) - # Not available on all versions: check for include file. - ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6 -echo "configure:3331: checking for dlfcn.h" >&5 -if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext < -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:3341: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -fi -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - - # NetBSD/SPARC needs -fPIC, -fpic will not do. - SHLIB_CFLAGS="-fPIC" - SHLIB_LD="ld -Bshareable -x" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - if test $doRpath = yes ; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' - fi - echo $ac_n "checking for ELF""... $ac_c" 1>&6 -echo "configure:3369: checking for ELF" >&5 -if eval "test \"`echo '$''{'tcl_cv_ld_elf'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - - cat > conftest.$ac_ext <&5 | - egrep "yes" >/dev/null 2>&1; then - rm -rf conftest* - tcl_cv_ld_elf=yes -else - rm -rf conftest* - tcl_cv_ld_elf=no -fi -rm -f conftest* - -fi - -echo "$ac_t""$tcl_cv_ld_elf" 1>&6 - if test $tcl_cv_ld_elf = yes; then - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so' - else - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - fi - -else - echo "$ac_t""no" 1>&6 - - SHLIB_CFLAGS="" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r" - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - -fi - - - # FreeBSD doesn't handle version numbers with dots. - - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - TCL_LIB_VERSIONS_OK=nodots - ;; OpenBSD-*) arch=`arch -s` case "$arch" in @@ -3450,13 +3355,13 @@ fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' echo $ac_n "checking for ELF""... $ac_c" 1>&6 -echo "configure:3454: checking for ELF" >&5 +echo "configure:3359: checking for ELF" >&5 if eval "test \"`echo '$''{'tcl_cv_ld_elf'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&6 UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' TCL_LIB_VERSIONS_OK=nodots ;; - NetBSD-*|FreeBSD-[3-4].*) - # FreeBSD 3.* and greater have ELF. - # NetBSD 2.* has ELF and can use 'cc -shared' to build shared libs + NetBSD-*) + # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' SHLIB_SUFFIX=".so" @@ -3521,7 +3425,7 @@ echo "$ac_t""$tcl_cv_ld_elf" 1>&6 # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-soname \$@" + TCL_SHLIB_LD_EXTRAS="-Wl,-soname \$@" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" @@ -3558,7 +3462,7 @@ echo "$ac_t""$tcl_cv_ld_elf" 1>&6 case `arch` in ppc) echo $ac_n "checking if compiler accepts -arch ppc64 flag""... $ac_c" 1>&6 -echo "configure:3562: checking if compiler accepts -arch ppc64 flag" >&5 +echo "configure:3466: checking if compiler accepts -arch ppc64 flag" >&5 if eval "test \"`echo '$''{'tcl_cv_cc_arch_ppc64'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -3566,14 +3470,14 @@ else hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:3481: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_cc_arch_ppc64=yes else @@ -3593,7 +3497,7 @@ echo "$ac_t""$tcl_cv_cc_arch_ppc64" 1>&6 fi;; i386) echo $ac_n "checking if compiler accepts -arch x86_64 flag""... $ac_c" 1>&6 -echo "configure:3597: checking if compiler accepts -arch x86_64 flag" >&5 +echo "configure:3501: checking if compiler accepts -arch x86_64 flag" >&5 if eval "test \"`echo '$''{'tcl_cv_cc_arch_x86_64'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -3601,14 +3505,14 @@ else hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch x86_64" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:3516: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_cc_arch_x86_64=yes else @@ -3637,7 +3541,7 @@ echo "$ac_t""$tcl_cv_cc_arch_x86_64" 1>&6 fi SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}' echo $ac_n "checking if ld accepts -single_module flag""... $ac_c" 1>&6 -echo "configure:3641: checking if ld accepts -single_module flag" >&5 +echo "configure:3545: checking if ld accepts -single_module flag" >&5 if eval "test \"`echo '$''{'tcl_cv_ld_single_module'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -3645,14 +3549,14 @@ else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:3560: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_ld_single_module=yes else @@ -3678,7 +3582,7 @@ echo "$ac_t""$tcl_cv_ld_single_module" 1>&6 LDFLAGS="$LDFLAGS -prebind" LDFLAGS="$LDFLAGS -headerpad_max_install_names" echo $ac_n "checking if ld accepts -search_paths_first flag""... $ac_c" 1>&6 -echo "configure:3682: checking if ld accepts -search_paths_first flag" >&5 +echo "configure:3586: checking if ld accepts -search_paths_first flag" >&5 if eval "test \"`echo '$''{'tcl_cv_ld_search_paths_first'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -3686,14 +3590,14 @@ else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:3601: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_ld_search_paths_first=yes else @@ -3716,7 +3620,7 @@ echo "$ac_t""$tcl_cv_ld_search_paths_first" 1>&6 PLAT_OBJS=\$\(MAC\_OSX_OBJS\) PLAT_SRCS=\$\(MAC\_OSX_SRCS\) echo $ac_n "checking whether to use CoreFoundation""... $ac_c" 1>&6 -echo "configure:3720: checking whether to use CoreFoundation" >&5 +echo "configure:3624: checking whether to use CoreFoundation" >&5 # Check whether --enable-corefoundation or --disable-corefoundation was given. if test "${enable_corefoundation+set}" = set; then enableval="$enable_corefoundation" @@ -3728,7 +3632,7 @@ fi echo "$ac_t""$tcl_corefoundation" 1>&6 if test $tcl_corefoundation = yes; then echo $ac_n "checking for CoreFoundation.framework""... $ac_c" 1>&6 -echo "configure:3732: checking for CoreFoundation.framework" >&5 +echo "configure:3636: checking for CoreFoundation.framework" >&5 if eval "test \"`echo '$''{'tcl_cv_lib_corefoundation'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -3742,14 +3646,14 @@ else done; fi LIBS="$LIBS -framework CoreFoundation" cat > conftest.$ac_ext < int main() { CFBundleRef b = CFBundleGetMainBundle(); ; return 0; } EOF -if { (eval echo configure:3753: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:3657: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_lib_corefoundation=yes else @@ -3776,7 +3680,7 @@ EOF fi if test "$fat_32_64" = yes -a $tcl_corefoundation = yes; then echo $ac_n "checking for 64-bit CoreFoundation""... $ac_c" 1>&6 -echo "configure:3780: checking for 64-bit CoreFoundation" >&5 +echo "configure:3684: checking for 64-bit CoreFoundation" >&5 if eval "test \"`echo '$''{'tcl_cv_lib_corefoundation_64'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -3785,14 +3689,14 @@ else eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done cat > conftest.$ac_ext < int main() { CFBundleRef b = CFBundleGetMainBundle(); ; return 0; } EOF -if { (eval echo configure:3796: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:3700: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_lib_corefoundation_64=yes else @@ -4121,7 +4025,7 @@ EOF # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers # that don't grok the -Bexport option. Test that it does. echo $ac_n "checking for ld accepts -Bexport flag""... $ac_c" 1>&6 -echo "configure:4125: checking for ld accepts -Bexport flag" >&5 +echo "configure:4029: checking for ld accepts -Bexport flag" >&5 if eval "test \"`echo '$''{'tcl_cv_ld_Bexport'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -4129,14 +4033,14 @@ else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-Bexport" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:4044: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_ld_Bexport=yes else @@ -4186,13 +4090,13 @@ echo "$ac_t""$tcl_cv_ld_Bexport" 1>&6 if test "x$DL_OBJS" = "xtclLoadAout.o" ; then echo $ac_n "checking sys/exec.h""... $ac_c" 1>&6 -echo "configure:4190: checking sys/exec.h" >&5 +echo "configure:4094: checking sys/exec.h" >&5 if eval "test \"`echo '$''{'tcl_cv_sysexec_h'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { @@ -4210,7 +4114,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:4214: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4118: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_sysexec_h=usable else @@ -4230,13 +4134,13 @@ EOF else echo $ac_n "checking a.out.h""... $ac_c" 1>&6 -echo "configure:4234: checking a.out.h" >&5 +echo "configure:4138: checking a.out.h" >&5 if eval "test \"`echo '$''{'tcl_cv_aout_h'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { @@ -4254,7 +4158,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:4258: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4162: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_aout_h=usable else @@ -4274,13 +4178,13 @@ EOF else echo $ac_n "checking sys/exec_aout.h""... $ac_c" 1>&6 -echo "configure:4278: checking sys/exec_aout.h" >&5 +echo "configure:4182: checking sys/exec_aout.h" >&5 if eval "test \"`echo '$''{'tcl_cv_sysexecaout_h'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { @@ -4298,7 +4202,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:4302: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4206: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_sysexecaout_h=usable else @@ -4416,12 +4320,12 @@ fi # warning when initializing a union member. echo $ac_n "checking for cast to union support""... $ac_c" 1>&6 -echo "configure:4420: checking for cast to union support" >&5 +echo "configure:4324: checking for cast to union support" >&5 if eval "test \"`echo '$''{'tcl_cv_cast_to_union'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4339: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_cast_to_union=yes else @@ -4486,7 +4390,7 @@ EOF echo $ac_n "checking for build with symbols""... $ac_c" 1>&6 -echo "configure:4490: checking for build with symbols" >&5 +echo "configure:4394: checking for build with symbols" >&5 # Check whether --enable-symbols or --disable-symbols was given. if test "${enable_symbols+set}" = set; then enableval="$enable_symbols" @@ -4551,21 +4455,21 @@ TCL_DBGX=${DBGX} echo $ac_n "checking for required early compiler flags""... $ac_c" 1>&6 -echo "configure:4555: checking for required early compiler flags" >&5 +echo "configure:4459: checking for required early compiler flags" >&5 tcl_flags="" if eval "test \"`echo '$''{'tcl_cv_flag__isoc99_source'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } EOF -if { (eval echo configure:4569: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4473: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_flag__isoc99_source=no else @@ -4573,7 +4477,7 @@ else cat conftest.$ac_ext >&5 rm -rf conftest* cat > conftest.$ac_ext < @@ -4581,7 +4485,7 @@ int main() { char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } EOF -if { (eval echo configure:4585: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4489: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_flag__isoc99_source=yes else @@ -4608,14 +4512,14 @@ EOF echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { struct stat64 buf; int i = stat64("/", &buf); ; return 0; } EOF -if { (eval echo configure:4619: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4523: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_flag__largefile64_source=no else @@ -4623,7 +4527,7 @@ else cat conftest.$ac_ext >&5 rm -rf conftest* cat > conftest.$ac_ext < @@ -4631,7 +4535,7 @@ int main() { struct stat64 buf; int i = stat64("/", &buf); ; return 0; } EOF -if { (eval echo configure:4635: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4539: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_flag__largefile64_source=yes else @@ -4658,14 +4562,14 @@ EOF echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { char *p = (char *)open64; ; return 0; } EOF -if { (eval echo configure:4669: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4573: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_flag__largefile_source64=no else @@ -4673,7 +4577,7 @@ else cat conftest.$ac_ext >&5 rm -rf conftest* cat > conftest.$ac_ext < @@ -4681,7 +4585,7 @@ int main() { char *p = (char *)open64; ; return 0; } EOF -if { (eval echo configure:4685: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4589: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_flag__largefile_source64=yes else @@ -4712,7 +4616,7 @@ EOF echo $ac_n "checking for 64-bit integer type""... $ac_c" 1>&6 -echo "configure:4716: checking for 64-bit integer type" >&5 +echo "configure:4620: checking for 64-bit integer type" >&5 if eval "test \"`echo '$''{'tcl_cv_type_64bit'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -4720,14 +4624,14 @@ else tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4635: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_type_64bit=__int64 else @@ -4741,7 +4645,7 @@ rm -f conftest* # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4658: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_type_64bit=${tcl_type_64bit} else @@ -4775,13 +4679,13 @@ EOF # Now check for auxiliary declarations echo $ac_n "checking for struct dirent64""... $ac_c" 1>&6 -echo "configure:4779: checking for struct dirent64" >&5 +echo "configure:4683: checking for struct dirent64" >&5 if eval "test \"`echo '$''{'tcl_cv_struct_dirent64'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include @@ -4789,7 +4693,7 @@ int main() { struct dirent64 p; ; return 0; } EOF -if { (eval echo configure:4793: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4697: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_struct_dirent64=yes else @@ -4810,13 +4714,13 @@ EOF fi echo $ac_n "checking for struct stat64""... $ac_c" 1>&6 -echo "configure:4814: checking for struct stat64" >&5 +echo "configure:4718: checking for struct stat64" >&5 if eval "test \"`echo '$''{'tcl_cv_struct_stat64'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { @@ -4824,7 +4728,7 @@ struct stat64 p; ; return 0; } EOF -if { (eval echo configure:4828: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4732: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_struct_stat64=yes else @@ -4847,12 +4751,12 @@ EOF for ac_func in open64 lseek64 do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:4851: checking for $ac_func" >&5 +echo "configure:4755: checking for $ac_func" >&5 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:4783: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -4900,13 +4804,13 @@ fi done echo $ac_n "checking for off64_t""... $ac_c" 1>&6 -echo "configure:4904: checking for off64_t" >&5 +echo "configure:4808: checking for off64_t" >&5 if eval "test \"`echo '$''{'tcl_cv_type_off64_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { @@ -4914,7 +4818,7 @@ off64_t offset; ; return 0; } EOF -if { (eval echo configure:4918: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4822: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_type_off64_t=yes else @@ -4946,14 +4850,14 @@ EOF #-------------------------------------------------------------------- echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6 -echo "configure:4950: checking whether byte ordering is bigendian" >&5 +echo "configure:4854: checking whether byte ordering is bigendian" >&5 if eval "test \"`echo '$''{'ac_cv_c_bigendian'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else ac_cv_c_bigendian=unknown # See if sys/param.h defines the BYTE_ORDER macro. cat > conftest.$ac_ext < #include @@ -4964,11 +4868,11 @@ int main() { #endif ; return 0; } EOF -if { (eval echo configure:4968: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4872: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* # It does; now see whether it defined to BIG_ENDIAN or not. cat > conftest.$ac_ext < #include @@ -4979,7 +4883,7 @@ int main() { #endif ; return 0; } EOF -if { (eval echo configure:4983: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:4887: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_bigendian=yes else @@ -4999,7 +4903,7 @@ if test "$cross_compiling" = yes; then { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; } else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:4920: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then ac_cv_c_bigendian=no else @@ -5045,12 +4949,12 @@ fi for ac_func in getcwd do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:5049: checking for $ac_func" >&5 +echo "configure:4953: checking for $ac_func" >&5 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:4981: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -5107,12 +5011,12 @@ done for ac_func in opendir strstr strtol strtoll strtoull tmpnam waitpid do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:5111: checking for $ac_func" >&5 +echo "configure:5015: checking for $ac_func" >&5 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5043: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -5162,12 +5066,12 @@ done echo $ac_n "checking for strerror""... $ac_c" 1>&6 -echo "configure:5166: checking for strerror" >&5 +echo "configure:5070: checking for strerror" >&5 if eval "test \"`echo '$''{'ac_cv_func_strerror'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5098: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_strerror=yes" else @@ -5214,12 +5118,12 @@ EOF fi echo $ac_n "checking for getwd""... $ac_c" 1>&6 -echo "configure:5218: checking for getwd" >&5 +echo "configure:5122: checking for getwd" >&5 if eval "test \"`echo '$''{'ac_cv_func_getwd'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5150: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_getwd=yes" else @@ -5266,12 +5170,12 @@ EOF fi echo $ac_n "checking for wait3""... $ac_c" 1>&6 -echo "configure:5270: checking for wait3" >&5 +echo "configure:5174: checking for wait3" >&5 if eval "test \"`echo '$''{'ac_cv_func_wait3'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5202: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_wait3=yes" else @@ -5318,12 +5222,12 @@ EOF fi echo $ac_n "checking for uname""... $ac_c" 1>&6 -echo "configure:5322: checking for uname" >&5 +echo "configure:5226: checking for uname" >&5 if eval "test \"`echo '$''{'ac_cv_func_uname'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5254: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_uname=yes" else @@ -5377,12 +5281,12 @@ if test "`uname -s`" = "Darwin" && test "${TCL_THREADS}" = 1 && \ ac_cv_func_realpath=no fi echo $ac_n "checking for realpath""... $ac_c" 1>&6 -echo "configure:5381: checking for realpath" >&5 +echo "configure:5285: checking for realpath" >&5 if eval "test \"`echo '$''{'ac_cv_func_realpath'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5313: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_realpath=yes" else @@ -5435,12 +5339,12 @@ fi if test "${TCL_THREADS}" = 1; then echo $ac_n "checking for getpwuid_r""... $ac_c" 1>&6 -echo "configure:5439: checking for getpwuid_r" >&5 +echo "configure:5343: checking for getpwuid_r" >&5 if eval "test \"`echo '$''{'ac_cv_func_getpwuid_r'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5371: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_getpwuid_r=yes" else @@ -5479,13 +5383,13 @@ if eval "test \"`echo '$ac_cv_func_'getpwuid_r`\" = yes"; then echo "$ac_t""yes" 1>&6 echo $ac_n "checking for getpwuid_r with 5 args""... $ac_c" 1>&6 -echo "configure:5483: checking for getpwuid_r with 5 args" >&5 +echo "configure:5387: checking for getpwuid_r with 5 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_getpwuid_r_5'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -5502,7 +5406,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:5506: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:5410: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_getpwuid_r_5=yes else @@ -5523,13 +5427,13 @@ EOF else echo $ac_n "checking for getpwuid_r with 4 args""... $ac_c" 1>&6 -echo "configure:5527: checking for getpwuid_r with 4 args" >&5 +echo "configure:5431: checking for getpwuid_r with 4 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_getpwuid_r_4'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -5546,7 +5450,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:5550: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:5454: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_getpwuid_r_4=yes else @@ -5579,12 +5483,12 @@ else fi echo $ac_n "checking for getpwnam_r""... $ac_c" 1>&6 -echo "configure:5583: checking for getpwnam_r" >&5 +echo "configure:5487: checking for getpwnam_r" >&5 if eval "test \"`echo '$''{'ac_cv_func_getpwnam_r'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5515: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_getpwnam_r=yes" else @@ -5623,13 +5527,13 @@ if eval "test \"`echo '$ac_cv_func_'getpwnam_r`\" = yes"; then echo "$ac_t""yes" 1>&6 echo $ac_n "checking for getpwnam_r with 5 args""... $ac_c" 1>&6 -echo "configure:5627: checking for getpwnam_r with 5 args" >&5 +echo "configure:5531: checking for getpwnam_r with 5 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_getpwnam_r_5'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -5646,7 +5550,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:5650: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:5554: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_getpwnam_r_5=yes else @@ -5667,13 +5571,13 @@ EOF else echo $ac_n "checking for getpwnam_r with 4 args""... $ac_c" 1>&6 -echo "configure:5671: checking for getpwnam_r with 4 args" >&5 +echo "configure:5575: checking for getpwnam_r with 4 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_getpwnam_r_4'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -5690,7 +5594,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:5694: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:5598: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_getpwnam_r_4=yes else @@ -5723,12 +5627,12 @@ else fi echo $ac_n "checking for getgrgid_r""... $ac_c" 1>&6 -echo "configure:5727: checking for getgrgid_r" >&5 +echo "configure:5631: checking for getgrgid_r" >&5 if eval "test \"`echo '$''{'ac_cv_func_getgrgid_r'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5659: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_getgrgid_r=yes" else @@ -5767,13 +5671,13 @@ if eval "test \"`echo '$ac_cv_func_'getgrgid_r`\" = yes"; then echo "$ac_t""yes" 1>&6 echo $ac_n "checking for getgrgid_r with 5 args""... $ac_c" 1>&6 -echo "configure:5771: checking for getgrgid_r with 5 args" >&5 +echo "configure:5675: checking for getgrgid_r with 5 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_getgrgid_r_5'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -5790,7 +5694,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:5794: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:5698: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_getgrgid_r_5=yes else @@ -5811,13 +5715,13 @@ EOF else echo $ac_n "checking for getgrgid_r with 4 args""... $ac_c" 1>&6 -echo "configure:5815: checking for getgrgid_r with 4 args" >&5 +echo "configure:5719: checking for getgrgid_r with 4 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_getgrgid_r_4'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -5834,7 +5738,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:5838: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:5742: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_getgrgid_r_4=yes else @@ -5867,12 +5771,12 @@ else fi echo $ac_n "checking for getgrnam_r""... $ac_c" 1>&6 -echo "configure:5871: checking for getgrnam_r" >&5 +echo "configure:5775: checking for getgrnam_r" >&5 if eval "test \"`echo '$''{'ac_cv_func_getgrnam_r'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5803: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_getgrnam_r=yes" else @@ -5911,13 +5815,13 @@ if eval "test \"`echo '$ac_cv_func_'getgrnam_r`\" = yes"; then echo "$ac_t""yes" 1>&6 echo $ac_n "checking for getgrnam_r with 5 args""... $ac_c" 1>&6 -echo "configure:5915: checking for getgrnam_r with 5 args" >&5 +echo "configure:5819: checking for getgrnam_r with 5 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_getgrnam_r_5'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -5934,7 +5838,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:5938: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:5842: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_getgrnam_r_5=yes else @@ -5955,13 +5859,13 @@ EOF else echo $ac_n "checking for getgrnam_r with 4 args""... $ac_c" 1>&6 -echo "configure:5959: checking for getgrnam_r with 4 args" >&5 +echo "configure:5863: checking for getgrnam_r with 4 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_getgrnam_r_4'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -5978,7 +5882,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:5982: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:5886: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_getgrnam_r_4=yes else @@ -6038,12 +5942,12 @@ EOF else echo $ac_n "checking for gethostbyname_r""... $ac_c" 1>&6 -echo "configure:6042: checking for gethostbyname_r" >&5 +echo "configure:5946: checking for gethostbyname_r" >&5 if eval "test \"`echo '$''{'ac_cv_func_gethostbyname_r'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:5974: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_gethostbyname_r=yes" else @@ -6082,13 +5986,13 @@ if eval "test \"`echo '$ac_cv_func_'gethostbyname_r`\" = yes"; then echo "$ac_t""yes" 1>&6 echo $ac_n "checking for gethostbyname_r with 6 args""... $ac_c" 1>&6 -echo "configure:6086: checking for gethostbyname_r with 6 args" >&5 +echo "configure:5990: checking for gethostbyname_r with 6 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_gethostbyname_r_6'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -6105,7 +6009,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:6109: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6013: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_gethostbyname_r_6=yes else @@ -6126,13 +6030,13 @@ EOF else echo $ac_n "checking for gethostbyname_r with 5 args""... $ac_c" 1>&6 -echo "configure:6130: checking for gethostbyname_r with 5 args" >&5 +echo "configure:6034: checking for gethostbyname_r with 5 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_gethostbyname_r_5'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -6149,7 +6053,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:6153: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6057: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_gethostbyname_r_5=yes else @@ -6170,13 +6074,13 @@ EOF else echo $ac_n "checking for gethostbyname_r with 3 args""... $ac_c" 1>&6 -echo "configure:6174: checking for gethostbyname_r with 3 args" >&5 +echo "configure:6078: checking for gethostbyname_r with 3 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_gethostbyname_r_3'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -6191,7 +6095,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:6195: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6099: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_gethostbyname_r_3=yes else @@ -6225,12 +6129,12 @@ else fi echo $ac_n "checking for gethostbyaddr_r""... $ac_c" 1>&6 -echo "configure:6229: checking for gethostbyaddr_r" >&5 +echo "configure:6133: checking for gethostbyaddr_r" >&5 if eval "test \"`echo '$''{'ac_cv_func_gethostbyaddr_r'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:6161: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_gethostbyaddr_r=yes" else @@ -6269,13 +6173,13 @@ if eval "test \"`echo '$ac_cv_func_'gethostbyaddr_r`\" = yes"; then echo "$ac_t""yes" 1>&6 echo $ac_n "checking for gethostbyaddr_r with 7 args""... $ac_c" 1>&6 -echo "configure:6273: checking for gethostbyaddr_r with 7 args" >&5 +echo "configure:6177: checking for gethostbyaddr_r with 7 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_gethostbyaddr_r_7'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -6295,7 +6199,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:6299: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6203: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_gethostbyaddr_r_7=yes else @@ -6316,13 +6220,13 @@ EOF else echo $ac_n "checking for gethostbyaddr_r with 8 args""... $ac_c" 1>&6 -echo "configure:6320: checking for gethostbyaddr_r with 8 args" >&5 +echo "configure:6224: checking for gethostbyaddr_r with 8 args" >&5 if eval "test \"`echo '$''{'tcl_cv_api_gethostbyaddr_r_8'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -6342,7 +6246,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:6346: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6250: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_api_gethostbyaddr_r_8=yes else @@ -6388,17 +6292,17 @@ fi do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:6392: checking for $ac_hdr" >&5 +echo "configure:6296: checking for $ac_hdr" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6402: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6306: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -6425,7 +6329,7 @@ fi done echo $ac_n "checking termios vs. termio vs. sgtty""... $ac_c" 1>&6 -echo "configure:6429: checking termios vs. termio vs. sgtty" >&5 +echo "configure:6333: checking termios vs. termio vs. sgtty" >&5 if eval "test \"`echo '$''{'tcl_cv_api_serial'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -6434,7 +6338,7 @@ else tcl_cv_api_serial=no else cat > conftest.$ac_ext < @@ -6449,7 +6353,7 @@ int main() { return 1; } EOF -if { (eval echo configure:6453: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:6357: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_api_serial=termios else @@ -6466,7 +6370,7 @@ fi tcl_cv_api_serial=no else cat > conftest.$ac_ext < @@ -6480,7 +6384,7 @@ int main() { return 1; } EOF -if { (eval echo configure:6484: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:6388: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_api_serial=termio else @@ -6498,7 +6402,7 @@ fi tcl_cv_api_serial=no else cat > conftest.$ac_ext < @@ -6513,7 +6417,7 @@ int main() { return 1; } EOF -if { (eval echo configure:6517: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:6421: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_api_serial=sgtty else @@ -6531,7 +6435,7 @@ fi tcl_cv_api_serial=no else cat > conftest.$ac_ext < @@ -6548,7 +6452,7 @@ int main() { return 1; } EOF -if { (eval echo configure:6552: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:6456: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_api_serial=termios else @@ -6566,7 +6470,7 @@ fi tcl_cv_api_serial=no else cat > conftest.$ac_ext < @@ -6582,7 +6486,7 @@ int main() { return 1; } EOF -if { (eval echo configure:6586: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:6490: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_api_serial=termio else @@ -6600,7 +6504,7 @@ fi tcl_cv_api_serial=none else cat > conftest.$ac_ext < @@ -6617,7 +6521,7 @@ int main() { return 1; } EOF -if { (eval echo configure:6621: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:6525: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_api_serial=sgtty else @@ -6660,20 +6564,20 @@ EOF #-------------------------------------------------------------------- echo $ac_n "checking for fd_set in sys/types""... $ac_c" 1>&6 -echo "configure:6664: checking for fd_set in sys/types" >&5 +echo "configure:6568: checking for fd_set in sys/types" >&5 if eval "test \"`echo '$''{'tcl_cv_type_fd_set'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { fd_set readMask, writeMask; ; return 0; } EOF -if { (eval echo configure:6677: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6581: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_type_fd_set=yes else @@ -6689,13 +6593,13 @@ echo "$ac_t""$tcl_cv_type_fd_set" 1>&6 tcl_ok=$tcl_cv_type_fd_set if test $tcl_ok = no; then echo $ac_n "checking for fd_mask in sys/select""... $ac_c" 1>&6 -echo "configure:6693: checking for fd_mask in sys/select" >&5 +echo "configure:6597: checking for fd_mask in sys/select" >&5 if eval "test \"`echo '$''{'tcl_cv_grep_fd_mask'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF @@ -6732,12 +6636,12 @@ fi #------------------------------------------------------------------------------ echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6 -echo "configure:6736: checking whether struct tm is in sys/time.h or time.h" >&5 +echo "configure:6640: checking whether struct tm is in sys/time.h or time.h" >&5 if eval "test \"`echo '$''{'ac_cv_struct_tm'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include @@ -6745,7 +6649,7 @@ int main() { struct tm *tp; tp->tm_sec; ; return 0; } EOF -if { (eval echo configure:6749: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6653: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm=time.h else @@ -6770,17 +6674,17 @@ fi do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:6774: checking for $ac_hdr" >&5 +echo "configure:6678: checking for $ac_hdr" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6784: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6688: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -6807,12 +6711,12 @@ fi done echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6 -echo "configure:6811: checking whether time.h and sys/time.h may both be included" >&5 +echo "configure:6715: checking whether time.h and sys/time.h may both be included" >&5 if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include @@ -6821,7 +6725,7 @@ int main() { struct tm *tp; ; return 0; } EOF -if { (eval echo configure:6825: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6729: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_time=yes else @@ -6842,12 +6746,12 @@ EOF fi echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6 -echo "configure:6846: checking for tm_zone in struct tm" >&5 +echo "configure:6750: checking for tm_zone in struct tm" >&5 if eval "test \"`echo '$''{'ac_cv_struct_tm_zone'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include <$ac_cv_struct_tm> @@ -6855,7 +6759,7 @@ int main() { struct tm tm; tm.tm_zone; ; return 0; } EOF -if { (eval echo configure:6859: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6763: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm_zone=yes else @@ -6875,12 +6779,12 @@ EOF else echo $ac_n "checking for tzname""... $ac_c" 1>&6 -echo "configure:6879: checking for tzname" >&5 +echo "configure:6783: checking for tzname" >&5 if eval "test \"`echo '$''{'ac_cv_var_tzname'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #ifndef tzname /* For SGI. */ @@ -6890,7 +6794,7 @@ int main() { atoi(*tzname); ; return 0; } EOF -if { (eval echo configure:6894: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:6798: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* ac_cv_var_tzname=yes else @@ -6915,12 +6819,12 @@ fi for ac_func in gmtime_r localtime_r do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:6919: checking for $ac_func" >&5 +echo "configure:6823: checking for $ac_func" >&5 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:6851: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -6969,20 +6873,20 @@ done echo $ac_n "checking tm_tzadj in struct tm""... $ac_c" 1>&6 -echo "configure:6973: checking tm_tzadj in struct tm" >&5 +echo "configure:6877: checking tm_tzadj in struct tm" >&5 if eval "test \"`echo '$''{'tcl_cv_member_tm_tzadj'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { struct tm tm; tm.tm_tzadj; ; return 0; } EOF -if { (eval echo configure:6986: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6890: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_member_tm_tzadj=yes else @@ -7003,20 +6907,20 @@ EOF fi echo $ac_n "checking tm_gmtoff in struct tm""... $ac_c" 1>&6 -echo "configure:7007: checking tm_gmtoff in struct tm" >&5 +echo "configure:6911: checking tm_gmtoff in struct tm" >&5 if eval "test \"`echo '$''{'tcl_cv_member_tm_gmtoff'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { struct tm tm; tm.tm_gmtoff; ; return 0; } EOF -if { (eval echo configure:7020: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6924: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_member_tm_gmtoff=yes else @@ -7041,13 +6945,13 @@ EOF # (like convex) have timezone functions, etc. # echo $ac_n "checking long timezone variable""... $ac_c" 1>&6 -echo "configure:7045: checking long timezone variable" >&5 +echo "configure:6949: checking long timezone variable" >&5 if eval "test \"`echo '$''{'tcl_cv_timezone_long'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { @@ -7056,7 +6960,7 @@ extern long timezone; exit (0); ; return 0; } EOF -if { (eval echo configure:7060: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:6964: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_timezone_long=yes else @@ -7079,13 +6983,13 @@ EOF # On some systems (eg IRIX 6.2), timezone is a time_t and not a long. # echo $ac_n "checking time_t timezone variable""... $ac_c" 1>&6 -echo "configure:7083: checking time_t timezone variable" >&5 +echo "configure:6987: checking time_t timezone variable" >&5 if eval "test \"`echo '$''{'tcl_cv_timezone_time'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { @@ -7094,7 +6998,7 @@ extern time_t timezone; exit (0); ; return 0; } EOF -if { (eval echo configure:7098: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:7002: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_timezone_time=yes else @@ -7122,12 +7026,12 @@ EOF #-------------------------------------------------------------------- if test "$ac_cv_cygwin" != "yes"; then echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6 -echo "configure:7126: checking for st_blksize in struct stat" >&5 +echo "configure:7030: checking for st_blksize in struct stat" >&5 if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include @@ -7135,7 +7039,7 @@ int main() { struct stat s; s.st_blksize; ; return 0; } EOF -if { (eval echo configure:7139: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:7043: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_st_blksize=yes else @@ -7157,12 +7061,12 @@ fi fi echo $ac_n "checking for fstatfs""... $ac_c" 1>&6 -echo "configure:7161: checking for fstatfs" >&5 +echo "configure:7065: checking for fstatfs" >&5 if eval "test \"`echo '$''{'ac_cv_func_fstatfs'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:7093: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_fstatfs=yes" else @@ -7214,7 +7118,7 @@ fi # data, this checks it and add memcmp.o to LIBOBJS if needed #-------------------------------------------------------------------- echo $ac_n "checking for 8-bit clean memcmp""... $ac_c" 1>&6 -echo "configure:7218: checking for 8-bit clean memcmp" >&5 +echo "configure:7122: checking for 8-bit clean memcmp" >&5 if eval "test \"`echo '$''{'ac_cv_func_memcmp_clean'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -7222,7 +7126,7 @@ else ac_cv_func_memcmp_clean=no else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:7140: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then ac_cv_func_memcmp_clean=yes else @@ -7256,12 +7160,12 @@ test $ac_cv_func_memcmp_clean = no && LIBOBJS="$LIBOBJS memcmp.${ac_objext}" # {The replacement define is in compat/string.h} #-------------------------------------------------------------------- echo $ac_n "checking for memmove""... $ac_c" 1>&6 -echo "configure:7260: checking for memmove" >&5 +echo "configure:7164: checking for memmove" >&5 if eval "test \"`echo '$''{'ac_cv_func_memmove'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:7192: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_memmove=yes" else @@ -7317,7 +7221,7 @@ fi #-------------------------------------------------------------------- if test "x${ac_cv_func_strstr}" = "xyes"; then echo $ac_n "checking proper strstr implementation""... $ac_c" 1>&6 -echo "configure:7321: checking proper strstr implementation" >&5 +echo "configure:7225: checking proper strstr implementation" >&5 if eval "test \"`echo '$''{'tcl_cv_strstr_unbroken'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -7326,7 +7230,7 @@ else tcl_cv_strstr_unbroken=broken else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:7243: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_strstr_unbroken=ok else @@ -7362,12 +7266,12 @@ fi #-------------------------------------------------------------------- echo $ac_n "checking for strtoul""... $ac_c" 1>&6 -echo "configure:7366: checking for strtoul" >&5 +echo "configure:7270: checking for strtoul" >&5 if eval "test \"`echo '$''{'ac_cv_func_strtoul'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:7298: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_strtoul=yes" else @@ -7412,7 +7316,7 @@ fi if test $tcl_ok = 1; then echo $ac_n "checking proper strtoul implementation""... $ac_c" 1>&6 -echo "configure:7416: checking proper strtoul implementation" >&5 +echo "configure:7320: checking proper strtoul implementation" >&5 if eval "test \"`echo '$''{'tcl_cv_strtoul_unbroken'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -7421,7 +7325,7 @@ else tcl_cv_strtoul_unbroken=broken else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:7345: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_strtoul_unbroken=ok else @@ -7466,12 +7370,12 @@ fi #-------------------------------------------------------------------- echo $ac_n "checking for strtod""... $ac_c" 1>&6 -echo "configure:7470: checking for strtod" >&5 +echo "configure:7374: checking for strtod" >&5 if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:7402: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_strtod=yes" else @@ -7516,7 +7420,7 @@ fi if test $tcl_ok = 1; then echo $ac_n "checking proper strtod implementation""... $ac_c" 1>&6 -echo "configure:7520: checking proper strtod implementation" >&5 +echo "configure:7424: checking proper strtod implementation" >&5 if eval "test \"`echo '$''{'tcl_cv_strtod_unbroken'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -7525,7 +7429,7 @@ else tcl_cv_strtod_unbroken=broken else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:7449: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_strtod_unbroken=ok else @@ -7573,12 +7477,12 @@ fi echo $ac_n "checking for strtod""... $ac_c" 1>&6 -echo "configure:7577: checking for strtod" >&5 +echo "configure:7481: checking for strtod" >&5 if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:7509: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_strtod=yes" else @@ -7623,7 +7527,7 @@ fi if test "$tcl_strtod" = 1; then echo $ac_n "checking for Solaris2.4/Tru64 strtod bugs""... $ac_c" 1>&6 -echo "configure:7627: checking for Solaris2.4/Tru64 strtod bugs" >&5 +echo "configure:7531: checking for Solaris2.4/Tru64 strtod bugs" >&5 if eval "test \"`echo '$''{'tcl_cv_strtod_buggy'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -7632,7 +7536,7 @@ else tcl_cv_strtod_buggy=buggy else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:7563: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_strtod_buggy=ok else @@ -7686,12 +7590,12 @@ EOF #-------------------------------------------------------------------- echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:7690: checking for ANSI C header files" >&5 +echo "configure:7594: checking for ANSI C header files" >&5 if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include @@ -7699,7 +7603,7 @@ else #include EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7703: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7607: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -7716,7 +7620,7 @@ rm -f conftest* if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -7734,7 +7638,7 @@ fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -7755,7 +7659,7 @@ if test "$cross_compiling" = yes; then : else cat > conftest.$ac_ext < #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') @@ -7766,7 +7670,7 @@ if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); exit (0); } EOF -if { (eval echo configure:7770: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:7674: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then : else @@ -7790,12 +7694,12 @@ EOF fi echo $ac_n "checking for mode_t""... $ac_c" 1>&6 -echo "configure:7794: checking for mode_t" >&5 +echo "configure:7698: checking for mode_t" >&5 if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #if STDC_HEADERS @@ -7823,12 +7727,12 @@ EOF fi echo $ac_n "checking for pid_t""... $ac_c" 1>&6 -echo "configure:7827: checking for pid_t" >&5 +echo "configure:7731: checking for pid_t" >&5 if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #if STDC_HEADERS @@ -7856,12 +7760,12 @@ EOF fi echo $ac_n "checking for size_t""... $ac_c" 1>&6 -echo "configure:7860: checking for size_t" >&5 +echo "configure:7764: checking for size_t" >&5 if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #if STDC_HEADERS @@ -7889,12 +7793,12 @@ EOF fi echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 -echo "configure:7893: checking for uid_t in sys/types.h" >&5 +echo "configure:7797: checking for uid_t in sys/types.h" >&5 if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF @@ -7924,13 +7828,13 @@ fi echo $ac_n "checking for socklen_t""... $ac_c" 1>&6 -echo "configure:7928: checking for socklen_t" >&5 +echo "configure:7832: checking for socklen_t" >&5 if eval "test \"`echo '$''{'ac_cv_type_socklen_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -7969,12 +7873,12 @@ fi #-------------------------------------------------------------------- echo $ac_n "checking for opendir""... $ac_c" 1>&6 -echo "configure:7973: checking for opendir" >&5 +echo "configure:7877: checking for opendir" >&5 if eval "test \"`echo '$''{'ac_cv_func_opendir'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:7905: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_opendir=yes" else @@ -8030,13 +7934,13 @@ fi #-------------------------------------------------------------------- echo $ac_n "checking union wait""... $ac_c" 1>&6 -echo "configure:8034: checking union wait" >&5 +echo "configure:7938: checking union wait" >&5 if eval "test \"`echo '$''{'tcl_cv_union_wait'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include @@ -8048,7 +7952,7 @@ WIFEXITED(x); /* Generates compiler error if WIFEXITED ; return 0; } EOF -if { (eval echo configure:8052: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:7956: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_union_wait=yes else @@ -8075,12 +7979,12 @@ fi #-------------------------------------------------------------------- echo $ac_n "checking for strncasecmp""... $ac_c" 1>&6 -echo "configure:8079: checking for strncasecmp" >&5 +echo "configure:7983: checking for strncasecmp" >&5 if eval "test \"`echo '$''{'ac_cv_func_strncasecmp'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:8011: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_strncasecmp=yes" else @@ -8125,7 +8029,7 @@ fi if test "$tcl_ok" = 0; then echo $ac_n "checking for strncasecmp in -lsocket""... $ac_c" 1>&6 -echo "configure:8129: checking for strncasecmp in -lsocket" >&5 +echo "configure:8033: checking for strncasecmp in -lsocket" >&5 ac_lib_var=`echo socket'_'strncasecmp | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -8133,7 +8037,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lsocket $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:8052: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8168,7 +8072,7 @@ fi fi if test "$tcl_ok" = 0; then echo $ac_n "checking for strncasecmp in -linet""... $ac_c" 1>&6 -echo "configure:8172: checking for strncasecmp in -linet" >&5 +echo "configure:8076: checking for strncasecmp in -linet" >&5 ac_lib_var=`echo inet'_'strncasecmp | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -8176,7 +8080,7 @@ else ac_save_LIBS="$LIBS" LIBS="-linet $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:8095: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8223,12 +8127,12 @@ fi #-------------------------------------------------------------------- echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6 -echo "configure:8227: checking for gettimeofday" >&5 +echo "configure:8131: checking for gettimeofday" >&5 if eval "test \"`echo '$''{'ac_cv_func_gettimeofday'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:8159: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_gettimeofday=yes" else @@ -8275,13 +8179,13 @@ EOF fi echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6 -echo "configure:8279: checking for gettimeofday declaration" >&5 +echo "configure:8183: checking for gettimeofday declaration" >&5 if eval "test \"`echo '$''{'tcl_cv_grep_gettimeofday'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF @@ -8312,14 +8216,14 @@ fi #-------------------------------------------------------------------- echo $ac_n "checking whether char is unsigned""... $ac_c" 1>&6 -echo "configure:8316: checking whether char is unsigned" >&5 +echo "configure:8220: checking whether char is unsigned" >&5 if eval "test \"`echo '$''{'ac_cv_c_char_unsigned'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else if test "$GCC" = yes; then # GCC predefines this symbol on systems where it applies. cat > conftest.$ac_ext <&2; exit 1; } else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:8259: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then ac_cv_c_char_unsigned=yes else @@ -8375,13 +8279,13 @@ EOF fi echo $ac_n "checking signed char declarations""... $ac_c" 1>&6 -echo "configure:8379: checking signed char declarations" >&5 +echo "configure:8283: checking signed char declarations" >&5 if eval "test \"`echo '$''{'tcl_cv_char_signed'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:8299: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_char_signed=yes else @@ -8416,7 +8320,7 @@ fi #-------------------------------------------------------------------- echo $ac_n "checking for a putenv() that copies the buffer""... $ac_c" 1>&6 -echo "configure:8420: checking for a putenv() that copies the buffer" >&5 +echo "configure:8324: checking for a putenv() that copies the buffer" >&5 if eval "test \"`echo '$''{'tcl_cv_putenv_copy'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -8425,7 +8329,7 @@ else tcl_cv_putenv_copy=no else cat > conftest.$ac_ext < @@ -8447,7 +8351,7 @@ else } EOF -if { (eval echo configure:8451: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null +if { (eval echo configure:8355: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null then tcl_cv_putenv_copy=no else @@ -8487,17 +8391,17 @@ fi if test "$langinfo_ok" = "yes"; then ac_safe=`echo "langinfo.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for langinfo.h""... $ac_c" 1>&6 -echo "configure:8491: checking for langinfo.h" >&5 +echo "configure:8395: checking for langinfo.h" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8501: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8405: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -8521,21 +8425,21 @@ fi fi echo $ac_n "checking whether to use nl_langinfo""... $ac_c" 1>&6 -echo "configure:8525: checking whether to use nl_langinfo" >&5 +echo "configure:8429: checking whether to use nl_langinfo" >&5 if test "$langinfo_ok" = "yes"; then if eval "test \"`echo '$''{'tcl_cv_langinfo_h'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < int main() { nl_langinfo(CODESET); ; return 0; } EOF -if { (eval echo configure:8539: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:8443: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* tcl_cv_langinfo_h=yes else @@ -8568,17 +8472,17 @@ if test "`uname -s`" = "Darwin" ; then do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:8572: checking for $ac_hdr" >&5 +echo "configure:8476: checking for $ac_hdr" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8582: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8486: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -8607,12 +8511,12 @@ done for ac_func in copyfile do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:8611: checking for $ac_func" >&5 +echo "configure:8515: checking for $ac_func" >&5 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:8543: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8664,17 +8568,17 @@ done do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:8668: checking for $ac_hdr" >&5 +echo "configure:8572: checking for $ac_hdr" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8678: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8582: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -8703,12 +8607,12 @@ done for ac_func in OSSpinLockLock do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:8707: checking for $ac_func" >&5 +echo "configure:8611: checking for $ac_func" >&5 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:8639: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8758,12 +8662,12 @@ done for ac_func in pthread_atfork do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:8762: checking for $ac_func" >&5 +echo "configure:8666: checking for $ac_func" >&5 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:8694: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8827,17 +8731,17 @@ EOF do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:8831: checking for $ac_hdr" >&5 +echo "configure:8735: checking for $ac_hdr" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8841: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8745: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -8865,14 +8769,14 @@ done if test "$ac_cv_header_AvailabilityMacros_h" = yes; then echo $ac_n "checking if weak import is available""... $ac_c" 1>&6 -echo "configure:8869: checking if weak import is available" >&5 +echo "configure:8773: checking if weak import is available" >&5 if eval "test \"`echo '$''{'tcl_cv_cc_weak_import'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:8796: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_cc_weak_import=yes else @@ -8916,13 +8820,13 @@ fi #-------------------------------------------------------------------- echo $ac_n "checking for fts""... $ac_c" 1>&6 -echo "configure:8920: checking for fts" >&5 +echo "configure:8824: checking for fts" >&5 if eval "test \"`echo '$''{'tcl_cv_api_fts'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < @@ -8937,7 +8841,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:8941: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:8845: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_api_fts=yes else @@ -8969,17 +8873,17 @@ fi do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:8973: checking for $ac_hdr" >&5 +echo "configure:8877: checking for $ac_hdr" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8983: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8887: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -9009,17 +8913,17 @@ done do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:9013: checking for $ac_hdr" >&5 +echo "configure:8917: checking for $ac_hdr" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9023: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8927: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -9047,7 +8951,7 @@ done echo $ac_n "checking system version""... $ac_c" 1>&6 -echo "configure:9051: checking system version" >&5 +echo "configure:8955: checking system version" >&5 if eval "test \"`echo '$''{'tcl_cv_sys_version'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -9078,7 +8982,7 @@ echo "$ac_t""$tcl_cv_sys_version" 1>&6 system=$tcl_cv_sys_version echo $ac_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O""... $ac_c" 1>&6 -echo "configure:9082: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5 +echo "configure:8986: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5 case $system in OSF*) cat >> confdefs.h <<\EOF @@ -9122,17 +9026,17 @@ fi if test $tcl_ok = yes; then ac_safe=`echo "sys/sdt.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/sdt.h""... $ac_c" 1>&6 -echo "configure:9126: checking for sys/sdt.h" >&5 +echo "configure:9030: checking for sys/sdt.h" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9136: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9040: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -9159,7 +9063,7 @@ if test $tcl_ok = yes; then # Extract the first word of "dtrace", so it can be a program name with args. set dummy dtrace; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:9163: checking for $ac_word" >&5 +echo "configure:9067: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_path_DTRACE'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -9194,7 +9098,7 @@ fi test -z "$ac_cv_path_DTRACE" && tcl_ok=no fi echo $ac_n "checking whether to enable DTrace support""... $ac_c" 1>&6 -echo "configure:9198: checking whether to enable DTrace support" >&5 +echo "configure:9102: checking whether to enable DTrace support" >&5 MAKEFILE_SHELL='/bin/sh' if test $tcl_ok = yes; then cat >> confdefs.h <<\EOF @@ -9224,13 +9128,13 @@ echo "$ac_t""$tcl_ok" 1>&6 #-------------------------------------------------------------------- echo $ac_n "checking whether the cpuid instruction is usable""... $ac_c" 1>&6 -echo "configure:9228: checking whether the cpuid instruction is usable" >&5 +echo "configure:9132: checking whether the cpuid instruction is usable" >&5 if eval "test \"`echo '$''{'tcl_cv_cpuid'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:9153: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* tcl_cv_cpuid=yes else @@ -9294,7 +9198,7 @@ if test "`uname -s`" = "Darwin" ; then if test "`uname -s`" = "Darwin" ; then echo $ac_n "checking how to package libraries""... $ac_c" 1>&6 -echo "configure:9298: checking how to package libraries" >&5 +echo "configure:9202: checking how to package libraries" >&5 # Check whether --enable-framework or --disable-framework was given. if test "${enable_framework+set}" = set; then enableval="$enable_framework" @@ -9574,34 +9478,15 @@ trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. -# -# If the first sed substitution is executed (which looks for macros that -# take arguments), then we branch to the quote section. Otherwise, -# look for a macro that doesn't take arguments. -cat >confdef2opt.sed <<\_ACEOF -t clear -: clear -s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g -t quote -s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g -t quote -d -: quote -s,[ `~#$^&*(){}\\|;'"<>?],\\&,g -s,\[,\\&,g -s,\],\\&,g -s,\$,$$,g -p -_ACEOF -# We use echo to avoid assuming a particular line-breaking character. -# The extra dot is to prevent the shell from consuming trailing -# line-breaks from the sub-command output. A line-break within -# single-quotes doesn't work because, if this script is created in a -# platform that uses two characters for line-breaks (e.g., DOS), tr -# would break. -ac_LF_and_DOT=`echo; echo .` -DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'` -rm -f confdef2opt.sed +cat > conftest.defs <<\EOF +s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g +s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g +s%\[%\\&%g +s%\]%\\&%g +s%\$%$$%g +EOF +DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` +rm -f conftest.defs # Without the "./", some shells look in PATH for config.status. diff --git a/unix/tcl.m4 b/unix/tcl.m4 index db64bbe..85b8f82 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1484,46 +1484,6 @@ dnl AC_CHECK_TOOL(AR, ar) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; - NetBSD-1.*|FreeBSD-[[1-2]].*) - # Not available on all versions: check for include file. - AC_CHECK_HEADER(dlfcn.h, [ - # NetBSD/SPARC needs -fPIC, -fpic will not do. - SHLIB_CFLAGS="-fPIC" - SHLIB_LD="ld -Bshareable -x" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - if test $doRpath = yes ; then - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' - fi - AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [ - AC_EGREP_CPP(yes, [ -#ifdef __ELF__ - yes -#endif - ], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)]) - if test $tcl_cv_ld_elf = yes; then - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so' - else - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - fi - ], [ - SHLIB_CFLAGS="" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r" - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - ]) - - # FreeBSD doesn't handle version numbers with dots. - - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - TCL_LIB_VERSIONS_OK=nodots - ;; OpenBSD-*) arch=`arch -s` case "$arch" in @@ -1573,9 +1533,8 @@ dnl AC_CHECK_TOOL(AR, ar) UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' TCL_LIB_VERSIONS_OK=nodots ;; - NetBSD-*|FreeBSD-[[3-4]].*) - # FreeBSD 3.* and greater have ELF. - # NetBSD 2.* has ELF and can use 'cc -shared' to build shared libs + NetBSD-*) + # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' SHLIB_SUFFIX=".so" @@ -1605,7 +1564,7 @@ dnl AC_CHECK_TOOL(AR, ar) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-soname \$[@]" + TCL_SHLIB_LD_EXTRAS="-Wl,-soname \$[@]" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" -- cgit v0.12 From 349564d2ad254c318eb5f8ac46ef2597621cd4ee Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 19 May 2013 14:04:07 +0000 Subject: Don't #define VOID on VxWorks, as it is already typdef'd to void Eliminate possibly conflicting LOCAL #define --- generic/regguts.h | 6 +++--- generic/tcl.h | 10 ++++++---- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/generic/regguts.h b/generic/regguts.h index ee5c596..b33753c 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -378,12 +378,12 @@ struct subre { # define CAP 010 /* capturing parens below */ # define BACKR 020 /* back reference below */ # define INUSE 0100 /* in use in final tree */ -# define LOCAL 03 /* bits which may not propagate up */ +# define NOPROP 03 /* bits which may not propagate up */ # define LMIX(f) ((f)<<2) /* LONGER -> MIXED */ # define SMIX(f) ((f)<<1) /* SHORTER -> MIXED */ -# define UP(f) (((f)&~LOCAL) | (LMIX(f) & SMIX(f) & MIXED)) +# define UP(f) (((f)&~NOPROP) | (LMIX(f) & SMIX(f) & MIXED)) # define MESSY(f) ((f)&(MIXED|CAP|BACKR)) -# define PREF(f) ((f)&LOCAL) +# define PREF(f) ((f)&NOPROP) # define PREF2(f1, f2) ((PREF(f1) != 0) ? PREF(f1) : PREF(f2)) # define COMBINE(f1, f2) (UP((f1)|(f2)) | PREF2(f1, f2)) short retry; /* index into retry memory */ diff --git a/generic/tcl.h b/generic/tcl.h index 5f47734..466ddcc 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -294,10 +294,12 @@ typedef long LONG; * non-ANSI systems. */ -#ifndef NO_VOID -# define VOID void -#else -# define VOID char +#ifndef __VXWORKS__ +# ifndef NO_VOID +# define VOID void +# else +# define VOID char +# endif #endif /* -- cgit v0.12 From 0eb5b1db67343f2a0f3ca3acaf567db4f3c7b9cf Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 20 May 2013 14:17:06 +0000 Subject: [3613567]: Corrected sense of test on results of access() in temp file creation. --- ChangeLog | 5 +++++ unix/tclUnixFCmd.c | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index b10acb6..ee43bb9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-05-20 Donal K. Fellows + + * unix/tclUnixFCmd.c (DefaultTempDir): [Bug 3613567]: Corrected logic + for checking return code of access() system call, which was inverted. + 2013-05-19 Jan Nijtmans * unix/tcl.m4: Fix for FreeBSD, and remove support for older diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 6f443a9..e27f78f 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -2226,13 +2226,13 @@ DefaultTempDir(void) dir = getenv("TMPDIR"); if (dir && dir[0] && stat(dir, &buf) == 0 && S_ISDIR(buf.st_mode) - && access(dir, W_OK)) { + && access(dir, W_OK) == 0) { return dir; } #ifdef P_tmpdir dir = P_tmpdir; - if (stat(dir, &buf) == 0 && S_ISDIR(buf.st_mode) && access(dir, W_OK)) { + if (stat(dir, &buf)==0 && S_ISDIR(buf.st_mode) && access(dir, W_OK)==0) { return dir; } #endif -- cgit v0.12 From dca34fd2a8e63fc14396f851889696c3793a2a1d Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 20 May 2013 15:10:18 +0000 Subject: 3613569 Handle case when TclpTempFileNameForLibrary returns NULL. --- generic/tclIOUtil.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 25ed57c..6259216 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -3225,6 +3225,9 @@ Tcl_LoadFile( */ copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr); + if (copyToPtr == NULL) { + return TCL_ERROR; + } Tcl_IncrRefCount(copyToPtr); copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); -- cgit v0.12 From f193acf08ce4f3fe6db1cb79ab3589d037e5853c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 May 2013 09:27:15 +0000 Subject: Proposed solution for 3613609: lsort -nocase does not sort non-ASCII correctly --- generic/tclCmdIL.c | 10 +++++----- generic/tclCmdMZ.c | 2 +- generic/tclInt.h | 1 + generic/tclUtf.c | 27 +++++++++++++++++++++++++++ tests/cmdIL.test | 3 +++ 5 files changed, 37 insertions(+), 6 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 152e61d..98ec8b4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2807,7 +2807,7 @@ Tcl_LsearchObjCmd( dataType = INTEGER; break; case LSEARCH_NOCASE: /* -nocase */ - strCmpFn = strcasecmp; + strCmpFn = TclUtfCasecmp; noCase = 1; break; case LSEARCH_NOT: /* -not */ @@ -3209,7 +3209,7 @@ Tcl_LsearchObjCmd( */ if (noCase) { - match = (strcasecmp(bytes, patternBytes) == 0); + match = (TclUtfCasecmp(bytes, patternBytes) == 0); } else { match = (memcmp(bytes, patternBytes, (size_t) length) == 0); @@ -3712,7 +3712,7 @@ Tcl_LsortObjCmd( goto done1; } elementArray[i].index.intValue = a; - } else if (sortInfo.sortMode == SORTMODE_REAL) { + } else if (sortMode == SORTMODE_REAL) { double a; if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; @@ -3790,7 +3790,7 @@ Tcl_LsortObjCmd( ckfree((char *)elementArray); done: - if (sortInfo.sortMode == SORTMODE_COMMAND) { + if (sortMode == SORTMODE_COMMAND) { TclDecrRefCount(sortInfo.compareCmdPtr); TclDecrRefCount(listObj); sortInfo.compareCmdPtr = NULL; @@ -3932,7 +3932,7 @@ SortCompare( order = strcmp(elemPtr1->index.strValuePtr, elemPtr2->index.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { - order = strcasecmp(elemPtr1->index.strValuePtr, + order = TclUtfCasecmp(elemPtr1->index.strValuePtr, elemPtr2->index.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { order = DictionaryCompare(elemPtr1->index.strValuePtr, diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0ad77aa..6fd468c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3436,7 +3436,7 @@ Tcl_SwitchObjCmd( i++; goto finishedOptions; case OPT_NOCASE: - strCmpFn = strcasecmp; + strCmpFn = TclUtfCasecmp; noCase = 1; break; diff --git a/generic/tclInt.h b/generic/tclInt.h index 92251fe..dc28b97 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2762,6 +2762,7 @@ MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); #endif MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr); +MODULE_SCOPE int TclUtfCasecmp(CONST char *cs, CONST char *ct); /* *---------------------------------------------------------------- diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 83900e9..9dacb53 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1101,6 +1101,33 @@ Tcl_UtfNcasecmp( } return 0; } + + +/* Replacement for strcasecmp in Tcl core, in places where UTF-8 should be handled. */ +int +TclUtfCasecmp( + CONST char *cs, /* UTF string to compare to ct. */ + CONST char *ct) /* UTF string cs is compared to. */ +{ + Tcl_UniChar ch1, ch2; + char c; + + do { + + /* If c == '\0', loop should end. */ + c = *cs; + + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { + ch1 = Tcl_UniCharToLower(ch1); + ch2 = Tcl_UniCharToLower(ch2); + if (ch1 != ch2) break; + } + } while (c); + return (ch1 - ch2); +} + /* *---------------------------------------------------------------------- diff --git a/tests/cmdIL.test b/tests/cmdIL.test index b387e71..c9a10b6 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -394,6 +394,9 @@ test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} { test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} { lsort -ascii -nocase {d E c B a D35 d300 100 20} } {100 20 a B c d d300 D35 E} +test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} { + lsort -ascii -nocase [list \u101 \u100] +} [list \u101 \u100] test cmdIL-5.1 {lsort with list style index} { lsort -ascii -decreasing -index {0 1} { -- cgit v0.12 From 52ae090e68314dd4aad0ba73e0869527bb321db4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 May 2013 09:38:05 +0000 Subject: Slight improvement: if cs = "\xC0\x80" and ct = "\x00", loop would continue after NUL-byte, this should not happen. --- generic/tclUtf.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 9dacb53..a7a2091 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1110,12 +1110,12 @@ TclUtfCasecmp( CONST char *ct) /* UTF string cs is compared to. */ { Tcl_UniChar ch1, ch2; - char c; + int goOn; do { - /* If c == '\0', loop should end. */ - c = *cs; + /* If *cs == '\0' or *ct == '\0', loop should end. */ + goOn = *cs && *ct; cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); @@ -1124,7 +1124,7 @@ TclUtfCasecmp( ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) break; } - } while (c); + } while (goOn); return (ch1 - ch2); } -- cgit v0.12 From 6ede2e9a9c11a27ad6be06a3eceda2f98be8f8d5 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 22 May 2013 10:36:55 +0000 Subject: * doc/file.n: [Bug 3613671]: Added note to portability section on the fact that [file owned] does not produce useful results on Windows. --- ChangeLog | 5 +++++ doc/file.n | 7 +++++++ 2 files changed, 12 insertions(+) diff --git a/ChangeLog b/ChangeLog index ee43bb9..553abbb 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-05-22 Donal K. Fellows + + * doc/file.n: [Bug 3613671]: Added note to portability section on the + fact that [file owned] does not produce useful results on Windows. + 2013-05-20 Donal K. Fellows * unix/tclUnixFCmd.c (DefaultTempDir): [Bug 3613567]: Corrected logic diff --git a/doc/file.n b/doc/file.n index eef4647..0b0ee9d 100644 --- a/doc/file.n +++ b/doc/file.n @@ -481,6 +481,13 @@ Returns \fB1\fR if file \fIname\fR is writable by the current user, . These commands always operate using the real user and group identifiers, not the effective ones. +.TP +\fBWindows\fR\0\0\0\0 +. +The \fbfile owned\fR subcommand currently always reports that the current user +is the owner of the file, without regard for what the operating system +believes to be true, making an ownership test useless. This issue (#3613671) +may be fixed in a future release of Tcl. .SH EXAMPLES .PP This procedure shows how to search for C files in a given directory -- cgit v0.12 From 5689a75644f9b109581a5dc3ae15294467c657ab Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 22 May 2013 12:32:28 +0000 Subject: Improved tests. --- tests/cmdIL.test | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/tests/cmdIL.test b/tests/cmdIL.test index c9a10b6..192c10c 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -395,8 +395,11 @@ test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} { lsort -ascii -nocase {d E c B a D35 d300 100 20} } {100 20 a B c d d300 D35 E} test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} { - lsort -ascii -nocase [list \u101 \u100] -} [list \u101 \u100] + scan [lsort -ascii -nocase [list \u101 \u100]] %c%c%c +} {257 32 256} +test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c +} {97 32 97 0 97} test cmdIL-5.1 {lsort with list style index} { lsort -ascii -decreasing -index {0 1} { -- cgit v0.12 From 75b8011dbad373e664a676ed8e3bcfec70313838 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 22 May 2013 12:55:50 +0000 Subject: Fixed the weird edge case. --- generic/tclUtf.c | 37 +++++++++++++++++++++++++------------ tests/cmdIL.test | 3 +++ 2 files changed, 28 insertions(+), 12 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index a7a2091..f3d1758 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1101,31 +1101,44 @@ Tcl_UtfNcasecmp( } return 0; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_UtfNcasecmp -- + * + * Compare UTF chars of string cs to string ct case insensitively. + * Replacement for strcasecmp in Tcl core, in places where UTF-8 should + * be handled. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - -/* Replacement for strcasecmp in Tcl core, in places where UTF-8 should be handled. */ int TclUtfCasecmp( CONST char *cs, /* UTF string to compare to ct. */ CONST char *ct) /* UTF string cs is compared to. */ { - Tcl_UniChar ch1, ch2; - int goOn; - - do { - - /* If *cs == '\0' or *ct == '\0', loop should end. */ - goOn = *cs && *ct; + while (*cs && *ct) { + Tcl_UniChar ch1, ch2; cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); - if (ch1 != ch2) break; + if (ch1 != ch2) { + return ch1 - ch2; + } } - } while (goOn); - return (ch1 - ch2); + } + return UCHAR(*cs) - UCHAR(*ct); } diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 192c10c..6fab269 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -400,6 +400,9 @@ test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} { test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} { scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c } {97 32 97 0 97} +test cmdIL-4.38 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list a a\u0000a]] %c%c%c%c%c +} {97 32 97 0 97} test cmdIL-5.1 {lsort with list style index} { lsort -ascii -decreasing -index {0 1} { -- cgit v0.12 From 376e9d0e30ef379c2c5c8de337f2467cbdb835e8 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 22 May 2013 13:14:18 +0000 Subject: silence compiler warning --- generic/tclCmdIL.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 98ec8b4..ea9c1e4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3460,7 +3460,8 @@ Tcl_LsortObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { - int i, j, index, indices, length, nocase = 0, sortMode, indexc; + int i, j, index, indices, length, nocase = 0, indexc; + int sortMode = SORTMODE_ASCII; Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; SortElement *elementArray, *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to -- cgit v0.12 From 3fad6ea7aff79c539045d7ae893fe71696ff3498 Mon Sep 17 00:00:00 2001 From: andreask Date: Wed, 22 May 2013 16:39:01 +0000 Subject: Removed const qualifier causing the HP native cc to error out (error 1675: Duplicate type qualifier "const"). --- ChangeLog | 5 +++++ generic/tclCompile.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 34fd231..cd18de0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-05-22 Andreas Kupries + + * tclCompile.c: Removed duplicate const qualifier causing the HP + native cc to error out. + 2013-05-22 Donal K. Fellows * generic/tclUtf.c (TclUtfCasecmp): [Bug 3613609]: Replace problematic diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f6dfbad..cdaf985 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -51,7 +51,7 @@ static int traceInitialized = 0; * existence of a procedure call frame to distinguish these. */ -const InstructionDesc const tclInstructionTable[] = { +InstructionDesc const tclInstructionTable[] = { /* Name Bytes stackEffect #Opnds Operand types */ {"done", 1, -1, 0, {OPERAND_NONE}}, /* Finish ByteCode execution and return stktop (top stack item) */ -- cgit v0.12 From 3d187689a8b892947e975457d3784bdc50b6ded0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 May 2013 11:28:18 +0000 Subject: When compiling Tcl with mingw32/wsl-4.0, make sure that no 64-bit time functions are used, which don't exist in Win95/98/ME. --- compat/strftime.c | 3 +++ win/tclWinTime.c | 3 +++ 2 files changed, 6 insertions(+) diff --git a/compat/strftime.c b/compat/strftime.c index 68016ac..d3a1075 100644 --- a/compat/strftime.c +++ b/compat/strftime.c @@ -44,6 +44,9 @@ * SUCH DAMAGE. */ +#if defined(_WIN32) && !defined(_WIN64) +# define _USE_32BIT_TIME_T +#endif #include #include #include diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 8fdc071..1e23459 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -10,6 +10,9 @@ * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#if defined(_WIN32) && !defined(_WIN64) +# define _USE_32BIT_TIME_T +#endif #include "tclWinInt.h" #define SECSPERDAY (60L * 60L * 24L) -- cgit v0.12 From 749f9c4ee0a50a7cedec339c2b3a69733fedf172 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 23 May 2013 18:32:19 +0000 Subject: Eliminate code duplication. --- generic/tclCompCmds.c | 72 +----------- generic/tclCompCmdsGR.c | 305 ------------------------------------------------ generic/tclCompCmdsSZ.c | 292 --------------------------------------------- generic/tclCompile.h | 65 +++++++++++ 4 files changed, 68 insertions(+), 666 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 2ac0fe3..e4b1087 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -31,11 +31,6 @@ static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); -static int PushVarName(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr, - int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr, - int line, int *clNext); static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); @@ -43,67 +38,6 @@ static int CompileDictEachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr, int collect); - -/* - * Macro that encapsulates an efficiency trick that avoids a function call for - * the simplest of compiles. The ANSI C "prototype" for this macro is: - * - * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp, int word); - */ - -#define CompileWord(envPtr, tokenPtr, interp, word) \ - if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ - } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ - } - -/* - * TIP #280: Remember the per-word line information of the current command. An - * index is used instead of a pointer as recursive compilation may reallocate, - * i.e. move, the array. This is also the reason to save the nuloc now, it may - * change during the course of the function. - * - * Macro to encapsulate the variable definition and setup. - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 - -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] - -#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ - PushVarName(i,v,e,f,l,s,sc, \ - mapPtr->loc[eclIndex].line[(word)], \ - mapPtr->loc[eclIndex].next[(word)]) - -/* - * Often want to issue one of two versions of an instruction based on whether - * the argument will fit in a single byte or not. This makes it much clearer. - */ - -#define Emit14Inst(nm,idx,envPtr) \ - if (idx <= 255) { \ - TclEmitInstInt1(nm##1,idx,envPtr); \ - } else { \ - TclEmitInstInt4(nm##4,idx,envPtr); \ - } - -/* - * Flags bits used by PushVarName. - */ - -#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ -#define TCL_NO_ELEMENT 2 /* Do not push the array element. */ - /* * The structures below define the AuxData types defined in this file. */ @@ -3329,7 +3263,7 @@ TclCompileFormatCmd( /* *---------------------------------------------------------------------- * - * PushVarName -- + * TclPushVarName -- * * Procedure used in the compiling where pushing a variable name is * necessary (append, lappend, set). @@ -3345,8 +3279,8 @@ TclCompileFormatCmd( *---------------------------------------------------------------------- */ -static int -PushVarName( +int +TclPushVarName( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Token *varTokenPtr, /* Points to a variable token. */ CompileEnv *envPtr, /* Holds resulting instructions. */ diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 26e63e8..2bd43b6 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -27,71 +27,7 @@ static void CompileReturnInternal(CompileEnv *envPtr, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); -static int PushVarName(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr, - int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr, - int line, int *clNext); -/* - * Macro that encapsulates an efficiency trick that avoids a function call for - * the simplest of compiles. The ANSI C "prototype" for this macro is: - * - * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp, int word); - */ - -#define CompileWord(envPtr, tokenPtr, interp, word) \ - if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ - } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ - } - -/* - * TIP #280: Remember the per-word line information of the current command. An - * index is used instead of a pointer as recursive compilation may reallocate, - * i.e. move, the array. This is also the reason to save the nuloc now, it may - * change during the course of the function. - * - * Macro to encapsulate the variable definition and setup. - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 - -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] - -#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ - PushVarName(i,v,e,f,l,s,sc, \ - mapPtr->loc[eclIndex].line[(word)], \ - mapPtr->loc[eclIndex].next[(word)]) - -/* - * Often want to issue one of two versions of an instruction based on whether - * the argument will fit in a single byte or not. This makes it much clearer. - */ - -#define Emit14Inst(nm,idx,envPtr) \ - if (idx <= 255) { \ - TclEmitInstInt1(nm##1,idx,envPtr); \ - } else { \ - TclEmitInstInt4(nm##4,idx,envPtr); \ - } - -/* - * Flags bits used by PushVarName. - */ - -#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ -#define TCL_NO_ELEMENT 2 /* Do not push the array element. */ /* *---------------------------------------------------------------------- @@ -2988,247 +2924,6 @@ TclCompileObjectSelfCmd( } /* - *---------------------------------------------------------------------- - * - * PushVarName -- - * - * Procedure used in the compiling where pushing a variable name is - * necessary (append, lappend, set). - * - * 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 "set" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -PushVarName( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Token *varTokenPtr, /* Points to a variable token. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ - int *localIndexPtr, /* Must not be NULL. */ - int *simpleVarNamePtr, /* Must not be NULL. */ - int *isScalarPtr, /* Must not be NULL. */ - int line, /* Line the token starts on. */ - int *clNext) /* Reference to offset of next hidden cont. - * line. */ -{ - register const char *p; - const char *name, *elName; - register int i, n; - Tcl_Token *elemTokenPtr = NULL; - int nameChars, elNameChars, simpleVarName, localIndex; - int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - simpleVarName = 0; - name = elName = NULL; - nameChars = elNameChars = 0; - localIndex = -1; - - /* - * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether - * curly braces surround the variable name. This really matters for array - * elements to handle things like - * set {x($foo)} 5 - * which raises an undefined var error if we are not careful here. - */ - - if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && - (varTokenPtr->start[0] != '{')) { - /* - * A simple variable name. Divide it up into "name" and "elName" - * strings. If it is not a local variable, look it up at runtime. - */ - - simpleVarName = 1; - - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (name[nameChars-1] == ')') { - /* - * last char is ')' => potential array reference. - */ - - for (i=0,p=name ; itype = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = elNameChars; - elemTokenPtr->numComponents = 0; - elemTokenCount = 1; - } - } - } else if (((n = varTokenPtr->numComponents) > 1) - && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { - /* - * Check for parentheses inside first token. - */ - - simpleVarName = 0; - for (i = 0, p = varTokenPtr[1].start; - i < varTokenPtr[1].size; i++, p++) { - if (*p == '(') { - simpleVarName = 1; - break; - } - } - if (simpleVarName) { - int remainingChars; - - /* - * Check the last token: if it is just ')', do not count it. - * Otherwise, remove the ')' and flag so that it is restored at - * the end. - */ - - if (varTokenPtr[n].size == 1) { - n--; - } else { - varTokenPtr[n].size--; - removedParen = n; - } - - name = varTokenPtr[1].start; - nameChars = p - varTokenPtr[1].start; - elName = p + 1; - remainingChars = (varTokenPtr[2].start - p) - 1; - elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2; - - if (remainingChars) { - /* - * Make a first token with the extra characters in the first - * token. - */ - - elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); - allocedTokens = 1; - elemTokenPtr->type = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = remainingChars; - elemTokenPtr->numComponents = 0; - elemTokenCount = n; - - /* - * Copy the remaining tokens. - */ - - memcpy(elemTokenPtr+1, varTokenPtr+2, - (n-1) * sizeof(Tcl_Token)); - } else { - /* - * Use the already available tokens. - */ - - elemTokenPtr = &varTokenPtr[2]; - elemTokenCount = n - 1; - } - } - } - - if (simpleVarName) { - /* - * See whether name has any namespace separators (::'s). - */ - - int hasNsQualifiers = 0; - - for (i = 0, p = name; i < nameChars; i++, p++) { - if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { - hasNsQualifiers = 1; - break; - } - } - - /* - * Look up the var name's index in the array of local vars in the proc - * frame. If retrieving the var's value and it doesn't already exist, - * push its name and look it up at runtime. - */ - - if (!hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, - 1, envPtr); - if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { - /* - * We'll push the name. - */ - - localIndex = -1; - } - } - if (localIndex < 0) { - PushLiteral(envPtr, name, nameChars); - } - - /* - * Compile the element script, if any, and only if not inhibited. [Bug - * 3600328] - */ - - if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { - if (elNameChars) { - envPtr->line = line; - envPtr->clNext = clNext; - TclCompileTokens(interp, elemTokenPtr, elemTokenCount, - envPtr); - } else { - PushLiteral(envPtr, "", 0); - } - } - } else { - /* - * The var name isn't simple: compile and push it. - */ - - envPtr->line = line; - envPtr->clNext = clNext; - CompileTokens(envPtr, varTokenPtr, interp); - } - - if (removedParen) { - varTokenPtr[removedParen].size++; - } - if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); - } - *localIndexPtr = localIndex; - *simpleVarNamePtr = simpleVarName; - *isScalarPtr = (elName == NULL); - return TCL_OK; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index f73beca..4a7d45b 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -27,11 +27,6 @@ static void FreeJumptableInfo(ClientData clientData); static void PrintJumptableInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); -static int PushVarName(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr, - int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr, - int line, int *clNext); static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); @@ -69,53 +64,6 @@ static int IssueTryInstructions(Tcl_Interp *interp, int *optionVarIndices, Tcl_Token **handlerTokens); /* - * Macro that encapsulates an efficiency trick that avoids a function call for - * the simplest of compiles. The ANSI C "prototype" for this macro is: - * - * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp, int word); - */ - -#define CompileWord(envPtr, tokenPtr, interp, word) \ - if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ - } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ - } - -/* - * TIP #280: Remember the per-word line information of the current command. An - * index is used instead of a pointer as recursive compilation may reallocate, - * i.e. move, the array. This is also the reason to save the nuloc now, it may - * change during the course of the function. - * - * Macro to encapsulate the variable definition and setup. - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 - -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] - -#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ - PushVarName(i,v,e,f,l,s,sc, \ - mapPtr->loc[eclIndex].line[(word)], \ - mapPtr->loc[eclIndex].next[(word)]) - -/* - * Flags bits used by PushVarName. - */ - -#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ - -/* * The structures below define the AuxData types defined in this file. */ @@ -3025,246 +2973,6 @@ TclCompileYieldCmd( /* *---------------------------------------------------------------------- * - * PushVarName -- - * - * Procedure used in the compiling where pushing a variable name is - * necessary (append, lappend, set). - * - * 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 "set" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -PushVarName( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Token *varTokenPtr, /* Points to a variable token. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int flags, /* TCL_NO_LARGE_INDEX. */ - int *localIndexPtr, /* Must not be NULL. */ - int *simpleVarNamePtr, /* Must not be NULL. */ - int *isScalarPtr, /* Must not be NULL. */ - int line, /* Line the token starts on. */ - int *clNext) /* Reference to offset of next hidden cont. - * line. */ -{ - register const char *p; - const char *name, *elName; - register int i, n; - Tcl_Token *elemTokenPtr = NULL; - int nameChars, elNameChars, simpleVarName, localIndex; - int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - simpleVarName = 0; - name = elName = NULL; - nameChars = elNameChars = 0; - localIndex = -1; - - /* - * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether - * curly braces surround the variable name. This really matters for array - * elements to handle things like - * set {x($foo)} 5 - * which raises an undefined var error if we are not careful here. - */ - - if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && - (varTokenPtr->start[0] != '{')) { - /* - * A simple variable name. Divide it up into "name" and "elName" - * strings. If it is not a local variable, look it up at runtime. - */ - - simpleVarName = 1; - - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (name[nameChars-1] == ')') { - /* - * last char is ')' => potential array reference. - */ - - for (i=0,p=name ; itype = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = elNameChars; - elemTokenPtr->numComponents = 0; - elemTokenCount = 1; - } - } - } else if (((n = varTokenPtr->numComponents) > 1) - && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { - /* - * Check for parentheses inside first token. - */ - - simpleVarName = 0; - for (i = 0, p = varTokenPtr[1].start; - i < varTokenPtr[1].size; i++, p++) { - if (*p == '(') { - simpleVarName = 1; - break; - } - } - if (simpleVarName) { - int remainingChars; - - /* - * Check the last token: if it is just ')', do not count it. - * Otherwise, remove the ')' and flag so that it is restored at - * the end. - */ - - if (varTokenPtr[n].size == 1) { - n--; - } else { - varTokenPtr[n].size--; - removedParen = n; - } - - name = varTokenPtr[1].start; - nameChars = p - varTokenPtr[1].start; - elName = p + 1; - remainingChars = (varTokenPtr[2].start - p) - 1; - elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2; - - if (remainingChars) { - /* - * Make a first token with the extra characters in the first - * token. - */ - - elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); - allocedTokens = 1; - elemTokenPtr->type = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = remainingChars; - elemTokenPtr->numComponents = 0; - elemTokenCount = n; - - /* - * Copy the remaining tokens. - */ - - memcpy(elemTokenPtr+1, varTokenPtr+2, - (n-1) * sizeof(Tcl_Token)); - } else { - /* - * Use the already available tokens. - */ - - elemTokenPtr = &varTokenPtr[2]; - elemTokenCount = n - 1; - } - } - } - - if (simpleVarName) { - /* - * See whether name has any namespace separators (::'s). - */ - - int hasNsQualifiers = 0; - - for (i = 0, p = name; i < nameChars; i++, p++) { - if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { - hasNsQualifiers = 1; - break; - } - } - - /* - * Look up the var name's index in the array of local vars in the proc - * frame. If retrieving the var's value and it doesn't already exist, - * push its name and look it up at runtime. - */ - - if (!hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, - 1, envPtr); - if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { - /* - * We'll push the name. - */ - - localIndex = -1; - } - } - if (localIndex < 0) { - PushLiteral(envPtr, name, nameChars); - } - - /* - * Compile the element script, if any. - */ - - if (elName != NULL) { - if (elNameChars) { - envPtr->line = line; - envPtr->clNext = clNext; - TclCompileTokens(interp, elemTokenPtr, elemTokenCount, - envPtr); - } else { - PushLiteral(envPtr, "", 0); - } - } - } else { - /* - * The var name isn't simple: compile and push it. - */ - - envPtr->line = line; - envPtr->clNext = clNext; - CompileTokens(envPtr, varTokenPtr, interp); - } - - if (removedParen) { - varTokenPtr[removedParen].size++; - } - if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); - } - *localIndexPtr = localIndex; - *simpleVarNamePtr = simpleVarName; - *isScalarPtr = (elName == NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * CompileUnaryOpCmd -- * * Utility routine to compile the unary operator commands. diff --git a/generic/tclCompile.h b/generic/tclCompile.h index bf00df9..1cc296e 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -998,6 +998,11 @@ MODULE_SCOPE void TclPrintObject(FILE *outFile, Tcl_Obj *objPtr, int maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, const char *string, int maxChars); +MODULE_SCOPE int TclPushVarName(Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr, + int flags, int *localIndexPtr, + int *simpleVarNamePtr, int *isScalarPtr, + int line, int *clNext); MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, char *bytes, int length, int flags); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -1428,6 +1433,66 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); Tcl_DStringLength(dsPtr), /*flags*/ 0) /* + * Macro that encapsulates an efficiency trick that avoids a function call for + * the simplest of compiles. The ANSI C "prototype" for this macro is: + * + * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp, int word); + */ + +#define CompileWord(envPtr, tokenPtr, interp, word) \ + if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ + TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ + (tokenPtr)[1].size), (envPtr)); \ + } else { \ + envPtr->line = mapPtr->loc[eclIndex].line[word]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ + TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)); \ + } + +/* + * TIP #280: Remember the per-word line information of the current command. An + * index is used instead of a pointer as recursive compilation may reallocate, + * i.e. move, the array. This is also the reason to save the nuloc now, it may + * change during the course of the function. + * + * Macro to encapsulate the variable definition and setup. + */ + +#define DefineLineInformation \ + ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ + int eclIndex = mapPtr->nuloc - 1 + +#define SetLineInformation(word) \ + envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] + +#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ + TclPushVarName(i,v,e,f,l,s,sc, \ + mapPtr->loc[eclIndex].line[(word)], \ + mapPtr->loc[eclIndex].next[(word)]) + +/* + * Often want to issue one of two versions of an instruction based on whether + * the argument will fit in a single byte or not. This makes it much clearer. + */ + +#define Emit14Inst(nm,idx,envPtr) \ + if (idx <= 255) { \ + TclEmitInstInt1(nm##1,idx,envPtr); \ + } else { \ + TclEmitInstInt4(nm##4,idx,envPtr); \ + } + +/* + * Flags bits used by TclPushVarName. + */ + +#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ +#define TCL_NO_ELEMENT 2 /* Do not push the array element. */ + +/* * DTrace probe macros (NOPs if DTrace support is not enabled). */ -- cgit v0.12 From 6075b0d3f07eeac6144d0a6f7af0803cf9705b96 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 23 May 2013 20:24:56 +0000 Subject: Spare developers the burden and error risk of counting bytes in string literals, or having to type them twice. --- generic/tclCompCmds.c | 72 +++++++++++++++++++++++-------------------------- generic/tclCompCmdsGR.c | 44 +++++++++++++++--------------- generic/tclCompCmdsSZ.c | 34 ++++++++++++----------- generic/tclCompile.h | 8 ++++-- 4 files changed, 81 insertions(+), 77 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index e4b1087..10faff7 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -295,7 +295,7 @@ TclCompileArraySetCmd( envPtr->currStackDepth = savedStackDepth; TclEmitOpcode( INST_POP, envPtr); } - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); goto done; } @@ -305,14 +305,12 @@ TclCompileArraySetCmd( if (isDataValid && !isDataEven) { savedStackDepth = envPtr->currStackDepth; - PushLiteral(envPtr, "list must have an even number of elements", - strlen("list must have an even number of elements")); - PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}", - strlen("-errorCode {TCL ARGUMENT FORMAT}")); + PushStringLiteral(envPtr, "list must have an even number of elements"); + PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); TclEmitInt4( 0, envPtr); envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); goto done; } @@ -376,15 +374,13 @@ TclCompileArraySetCmd( TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); - PushLiteral(envPtr, "1", 1); + PushStringLiteral(envPtr, "1"); TclEmitOpcode( INST_BITAND, envPtr); offsetFwd = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); savedStackDepth = envPtr->currStackDepth; - PushLiteral(envPtr, "list must have an even number of elements", - strlen("list must have an even number of elements")); - PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}", - strlen("-errorCode {TCL ARGUMENT FORMAT}")); + PushStringLiteral(envPtr, "list must have an even number of elements"); + PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); TclEmitInt4( 0, envPtr); envPtr->currStackDepth = savedStackDepth; @@ -441,7 +437,7 @@ TclCompileArraySetCmd( TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( dataVar, envPtr); } - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); done: Tcl_DecrRefCount(literalObj); return TCL_OK; @@ -485,7 +481,7 @@ TclCompileArrayUnsetCmd( envPtr->currStackDepth = savedStackDepth; TclEmitOpcode( INST_POP, envPtr); } - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -525,7 +521,7 @@ TclCompileBreakCmd( */ TclEmitOpcode(INST_BREAK, envPtr); - PushLiteral(envPtr, "", 0); /* Evil hack! */ + PushStringLiteral(envPtr, ""); /* Evil hack! */ return TCL_OK; } @@ -674,7 +670,7 @@ TclCompileCatchCmd( */ TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "0", 1); + PushStringLiteral(envPtr, "0"); TclEmitInstInt1( INST_JUMP1, 3, envPtr); envPtr->currStackDepth = savedStackDepth; ExceptionRangeTarget(envPtr, range, catchOffset); @@ -696,7 +692,7 @@ TclCompileCatchCmd( * and jump around the "error case" code. */ - PushLiteral(envPtr, "0", 1); + PushStringLiteral(envPtr, "0"); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* Stack at this point: ?script? result TCL_OK */ @@ -832,7 +828,7 @@ TclCompileContinueCmd( */ TclEmitOpcode(INST_CONTINUE, envPtr); - PushLiteral(envPtr, "", 0); /* Evil hack! */ + PushStringLiteral(envPtr, ""); /* Evil hack! */ return TCL_OK; } @@ -1208,7 +1204,7 @@ TclCompileDictCreateCmd( return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); } - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); Emit14Inst( INST_STORE_SCALAR, worker, envPtr); TclEmitOpcode( INST_POP, envPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1247,7 +1243,7 @@ TclCompileDictMergeCmd( */ if (parsePtr->numWords < 2) { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } else if (parsePtr->numWords == 2) { tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1477,7 +1473,7 @@ CompileDictEachCmd( */ if (collect == TCL_EACH_COLLECT) { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -1615,7 +1611,7 @@ CompileDictEachCmd( TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( collectVar, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } return TCL_OK; } @@ -1991,18 +1987,18 @@ TclCompileDictWithCmd( TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } else { /* * Case: Direct dict in LVT with empty body. */ - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } } else { if (gotPath) { @@ -2021,7 +2017,7 @@ TclCompileDictWithCmd( TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } else { /* * Case: Direct dict in non-simple var with empty body. @@ -2030,12 +2026,12 @@ TclCompileDictWithCmd( CompileWord(envPtr, varTokenPtr, interp, 0); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); TclEmitOpcode( INST_DICT_EXPAND, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); TclEmitInstInt4(INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } } envPtr->currStackDepth = savedStackDepth + 1; @@ -2088,7 +2084,7 @@ TclCompileDictWithCmd( if (gotPath) { Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } TclEmitOpcode( INST_DICT_EXPAND, envPtr); Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr); @@ -2119,7 +2115,7 @@ TclCompileDictWithCmd( if (gotPath) { Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); if (dictVar == -1) { @@ -2143,7 +2139,7 @@ TclCompileDictWithCmd( if (parsePtr->numWords > 3) { Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); if (dictVar == -1) { @@ -2265,7 +2261,7 @@ TclCompileErrorCmd( } messageTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushLiteral(envPtr, "-code error -level 0", 20); + PushStringLiteral(envPtr, "-code error -level 0"); CompileWord(envPtr, messageTokenPtr, interp, 1); TclEmitOpcode(INST_RETURN_STK, envPtr); envPtr->currStackDepth = savedStackDepth + 1; @@ -2478,7 +2474,7 @@ TclCompileForCmd( */ envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -2788,7 +2784,7 @@ CompileEachloopCmd( */ if (collect == TCL_EACH_COLLECT) { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -2881,7 +2877,7 @@ CompileEachloopCmd( TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( collectVar, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } envPtr->currStackDepth = savedStackDepth + 1; @@ -3253,7 +3249,7 @@ TclCompileFormatCmd( */ TclEmitOpcode(INST_DUP, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); TclEmitOpcode(INST_STR_EQ, envPtr); TclEmitOpcode(INST_POP, envPtr); } @@ -3476,7 +3472,7 @@ TclPushVarName( TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } } } else { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 2bd43b6..13b874e 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -77,7 +77,7 @@ TclCompileGlobalCmd( * Push the namespace */ - PushLiteral(envPtr, "::", 2); + PushStringLiteral(envPtr, "::"); /* * Loop over the variables. @@ -100,7 +100,7 @@ TclCompileGlobalCmd( */ TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -376,7 +376,7 @@ TclCompileIfCmd( */ if (compileScripts) { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } } @@ -1203,7 +1203,7 @@ TclCompileListCmd( * [list] without arguments just pushes an empty object. */ - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -1545,7 +1545,7 @@ TclCompileLreplaceCmd( if (guaranteedDropAll) { TclEmitOpcode( INST_LIST_LENGTH, envPtr); TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } else { TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); TclEmitInt4( idx2, envPtr); @@ -1811,8 +1811,8 @@ TclCompileNamespaceCodeCmd( * the value needs to be determined at runtime for safety. */ - PushLiteral(envPtr, "::namespace", 11); - PushLiteral(envPtr, "inscope", 7); + PushStringLiteral(envPtr, "::namespace"); + PushStringLiteral(envPtr, "inscope"); TclEmitOpcode( INST_NS_CURRENT, envPtr); CompileWord(envPtr, tokenPtr, interp, 1); TclEmitInstInt4( INST_LIST, 4, envPtr); @@ -1837,17 +1837,17 @@ TclCompileNamespaceQualifiersCmd( } CompileWord(envPtr, tokenPtr, interp, 1); - PushLiteral(envPtr, "0", 1); - PushLiteral(envPtr, "::", 2); + PushStringLiteral(envPtr, "0"); + PushStringLiteral(envPtr, "::"); TclEmitInstInt4( INST_OVER, 2, envPtr); TclEmitOpcode( INST_STR_FIND_LAST, envPtr); off = CurrentOffset(envPtr); - PushLiteral(envPtr, "1", 1); + PushStringLiteral(envPtr, "1"); TclEmitOpcode( INST_SUB, envPtr); TclEmitInstInt4( INST_OVER, 2, envPtr); TclEmitInstInt4( INST_OVER, 1, envPtr); TclEmitOpcode( INST_STR_INDEX, envPtr); - PushLiteral(envPtr, ":", 1); + PushStringLiteral(envPtr, ":"); TclEmitOpcode( INST_STR_EQ, envPtr); off = off - CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); @@ -1877,17 +1877,17 @@ TclCompileNamespaceTailCmd( */ CompileWord(envPtr, tokenPtr, interp, 1); - PushLiteral(envPtr, "::", 2); + PushStringLiteral(envPtr, "::"); TclEmitInstInt4( INST_OVER, 1, envPtr); TclEmitOpcode( INST_STR_FIND_LAST, envPtr); TclEmitOpcode( INST_DUP, envPtr); - PushLiteral(envPtr, "0", 1); + PushStringLiteral(envPtr, "0"); TclEmitOpcode( INST_GE, envPtr); TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); - PushLiteral(envPtr, "2", 1); + PushStringLiteral(envPtr, "2"); TclEmitOpcode( INST_ADD, envPtr); TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); - PushLiteral(envPtr, "end", 3); + PushStringLiteral(envPtr, "end"); TclEmitOpcode( INST_STR_RANGE, envPtr); return TCL_OK; } @@ -1951,7 +1951,7 @@ TclCompileNamespaceUpvarCmd( */ TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -2117,7 +2117,7 @@ TclCompileRegexpCmd( * The semantics of regexp are always match on re == "". */ - PushLiteral(envPtr, "1", 1); + PushStringLiteral(envPtr, "1"); return TCL_OK; } @@ -2459,7 +2459,7 @@ TclCompileReturnCmd( * No explict result argument, so default result is empty string. */ - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } /* @@ -2534,7 +2534,7 @@ TclCompileReturnCmd( if (explicitResult) { CompileWord(envPtr, wordTokenPtr, interp, numWords-1); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } /* @@ -2646,7 +2646,7 @@ TclCompileUpvarCmd( if (!(numWords%2)) { return TCL_ERROR; } - PushLiteral(envPtr, "1", 1); + PushStringLiteral(envPtr, "1"); otherTokenPtr = tokenPtr; i = 3; } @@ -2679,7 +2679,7 @@ TclCompileUpvarCmd( */ TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -2760,7 +2760,7 @@ TclCompileVariableCmd( * Set the result to empty */ - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 4a7d45b..7ce51b6 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -88,7 +88,7 @@ const AuxDataType tclJumptableInfoType = { #define BODY(token,index) \ SetLineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ - PushLiteral(envPtr,(str),strlen(str)) + PushStringLiteral(envPtr, str) #define JUMP(var,name) \ (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr) #define FIXJUMP(var) \ @@ -757,7 +757,7 @@ TclSubstCompile( tokenPtr = parse.tokenPtr; if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) { - PushLiteral(envPtr, "", 0); + PUSH(""); count++; } @@ -1420,7 +1420,7 @@ IssueSwitchChainedTests( * when the RE == "". */ - PushLiteral(envPtr, "1", 1); + PUSH("1"); break; } @@ -1545,7 +1545,7 @@ IssueSwitchChainedTests( if (!foundDefault) { OP( POP); - PushLiteral(envPtr, "", 0); + PUSH(""); } /* @@ -1764,7 +1764,7 @@ IssueSwitchJumpTable( envPtr->currStackDepth = savedStackDepth; TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, envPtr->codeStart+jumpToDefault+1); - PushLiteral(envPtr, "", 0); + PUSH(""); } /* @@ -2338,10 +2338,11 @@ IssueTryInstructions( for (i=0 ; icurrStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + PUSH(""); return TCL_OK; } @@ -2959,7 +2963,7 @@ TclCompileYieldCmd( } if (parsePtr->numWords == 1) { - PushLiteral(envPtr, "", 0); + PUSH(""); } else { DefineLineInformation; /* TIP #280 */ Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -3125,7 +3129,7 @@ CompileComparisonOpCmd( DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords < 3) { - PushLiteral(envPtr, "1", 1); + PUSH("1"); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); @@ -3296,7 +3300,7 @@ TclCompilePowOpCmd( CompileWord(envPtr, tokenPtr, interp, words); } if (parsePtr->numWords <= 2) { - PushLiteral(envPtr, "1", 1); + PUSH("1"); words++; } while (--words > 1) { @@ -3514,7 +3518,7 @@ TclCompileDivOpCmd( return TCL_ERROR; } if (parsePtr->numWords == 2) { - PushLiteral(envPtr, "1.0", 3); + PUSH("1.0"); } for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1cc296e..3909fa9 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1358,15 +1358,19 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)); /* - * Convenience macro for use when pushing literals. The ANSI C "prototype" for - * this macro is: + * Convenience macros for use when pushing literals. The ANSI C "prototype" for + * these macros are: * * static void PushLiteral(CompileEnv *envPtr, * const char *string, int length); + * static void PushStringLiteral(CompileEnv *envPtr, + * const char *string); */ #define PushLiteral(envPtr, string, length) \ TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) +#define PushStringLiteral(envPtr, string) \ + PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1)) /* * Macro to advance to the next token; it is more mnemonic than the address -- cgit v0.12 From 44c1eaa96ca8158ccbb3acddb45eadfadfb9f07a Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 24 May 2013 18:37:19 +0000 Subject: 3613854 - Fixup stack maintenance /code generation for [array set x $oddList]. Postscript - I see that this commit created a memory leak. Will commit a fix within a few days. --- generic/tclCompCmds.c | 37 +++++++++++++++++-------------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 10faff7..5a5cd88 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -263,11 +263,6 @@ TclCompileArraySetCmd( } varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &simpleVarName, &isScalar, 1); - if (!isScalar) { - return TCL_ERROR; - } dataTokenPtr = TokenAfter(varTokenPtr); literalObj = Tcl_NewObj(); isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); @@ -276,6 +271,23 @@ TclCompileArraySetCmd( isDataEven = (isDataValid && (len & 1) == 0); /* + * Special case: literal odd-length argument is always an error. + */ + + if (isDataValid && !isDataEven) { + PushStringLiteral(envPtr, "list must have an even number of elements"); + PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); + TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); + TclEmitInt4( 0, envPtr); + goto done; + } + + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar) { + return TCL_ERROR; + } + /* * Special case: literal empty value argument is just an "ensure array" * operation. */ @@ -300,21 +312,6 @@ TclCompileArraySetCmd( } /* - * Special case: literal odd-length argument is always an error. - */ - - if (isDataValid && !isDataEven) { - savedStackDepth = envPtr->currStackDepth; - PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); - TclEmitInt4( 0, envPtr); - envPtr->currStackDepth = savedStackDepth; - PushStringLiteral(envPtr, ""); - goto done; - } - - /* * Prepare for the internal foreach. */ -- cgit v0.12 From 4a770ed0b5648f58f0ba0b07bb73cc904db339e0 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 25 May 2013 03:26:21 +0000 Subject: Repair some stack depth housekeeping. --- generic/tclCompCmds.c | 1 + generic/tclCompCmdsGR.c | 5 ----- generic/tclCompCmdsSZ.c | 2 +- generic/tclCompile.c | 2 +- 4 files changed, 3 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5a5cd88..8c88649 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1329,6 +1329,7 @@ TclCompileDictMergeCmd( TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); + TclAdjustStackDepth(-1, envPtr); return TCL_OK; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 13b874e..c6a01e7 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2375,7 +2375,6 @@ TclCompileReturnCmd( int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; - int savedStackDepth = envPtr->currStackDepth; Tcl_Obj *returnOpts, **objv; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); DefineLineInformation; /* TIP #280 */ @@ -2398,7 +2397,6 @@ TclCompileReturnCmd( CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); TclEmitOpcode(INST_RETURN_STK, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -2494,7 +2492,6 @@ TclCompileReturnCmd( Tcl_DecrRefCount(returnOpts); TclEmitOpcode(INST_DONE, envPtr); - envPtr->currStackDepth = savedStackDepth; return TCL_OK; } } @@ -2512,7 +2509,6 @@ TclCompileReturnCmd( */ CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); - envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; issueRuntimeReturn: @@ -2542,7 +2538,6 @@ TclCompileReturnCmd( */ TclEmitOpcode(INST_RETURN_STK, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 7ce51b6..f2017f0 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -938,7 +938,7 @@ TclSubstCompile( * that is too low. Here we manually fix that up. */ - TclAdjustStackDepth(5, envPtr); + TclAdjustStackDepth(4, envPtr); /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cdaf985..87e620c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -310,7 +310,7 @@ InstructionDesc const tclInstructionTable[] = { {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, /* Push the interpreter's return option dictionary as an object on the * stack. */ - {"returnStk", 1, -2, 0, {OPERAND_NONE}}, + {"returnStk", 1, -1, 0, {OPERAND_NONE}}, /* Compiled [return]; options and result are on the stack, code and * level are in the options. */ -- cgit v0.12 From 9eb03d3c23ab2d942ace763871d1674f3884ea9a Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 May 2013 14:04:02 +0000 Subject: Missed bits of dup code elimination. --- generic/tclAssembly.c | 23 ----------------------- 1 file changed, 23 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index fff7b43..a84467f 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -324,29 +324,6 @@ static const Tcl_ObjType assembleCodeType = { }; /* - * TIP #280: Remember the per-word line information of the current command. An - * index is used instead of a pointer as recursive compilation may reallocate, - * i.e. move, the array. This is also the reason to save the nuloc now, it may - * change during the course of the function. - * - * Macro to encapsulate the variable definition and setup. - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 - -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] - -/* - * Flags bits used by PushVarName. - */ - -#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ - -/* * Source instructions recognized in the Tcl Assembly Language (TAL) */ -- cgit v0.12 From 03f2ab38fee4863f2ea67292b07ca9cc56ddee48 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 May 2013 14:29:01 +0000 Subject: Plug the memory leak. Greater ambitions to improve this routine are proving more difficult than expected. --- generic/tclCompCmds.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 8c88649..a325954 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -285,6 +285,7 @@ TclCompileArraySetCmd( PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, &localIndex, &simpleVarName, &isScalar, 1); if (!isScalar) { + Tcl_DecrRefCount(literalObj); return TCL_ERROR; } /* -- cgit v0.12 From 8221c0695aa992657960abbd3d850a9503c633ca Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 May 2013 19:21:22 +0000 Subject: Use the routines that provide "basic compile" instead of reinventing them. --- generic/tclCompCmds.c | 50 ++++++++++++++++---------------------------------- 1 file changed, 16 insertions(+), 34 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a325954..a966715 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -251,7 +251,7 @@ TclCompileArraySetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *dataTokenPtr; - int simpleVarName, isScalar, localIndex; + int simpleVarName, isScalar, localIndex, code = TCL_OK; int isDataLiteral, isDataValid, isDataEven, len; int dataVar, iterVar, keyVar, valVar, infoIndex; int back, fwd, offsetBack, offsetFwd, savedStackDepth; @@ -282,11 +282,21 @@ TclCompileArraySetCmd( goto done; } + /* + * Except for the special "ensure array" case below, when we're not in + * a proc, we cannot do a better compile than generic. + */ + + if (envPtr->procPtr == NULL && !(isDataEven && len == 0)) { + code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); + goto done; + } + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, &localIndex, &simpleVarName, &isScalar, 1); if (!isScalar) { - Tcl_DecrRefCount(literalObj); - return TCL_ERROR; + code = TCL_ERROR; + goto done; } /* * Special case: literal empty value argument is just an "ensure array" @@ -302,10 +312,10 @@ TclCompileArraySetCmd( TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); - savedStackDepth = envPtr->currStackDepth; TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); TclEmitInstInt1(INST_JUMP1, 3, envPtr); - envPtr->currStackDepth = savedStackDepth; + /* Each branch decrements stack depth, but we only take one. */ + TclAdjustStackDepth(1, envPtr); TclEmitOpcode( INST_POP, envPtr); } PushStringLiteral(envPtr, ""); @@ -321,32 +331,6 @@ TclCompileArraySetCmd( keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - if (dataVar < 0) { - /* - * Right number of arguments, but not compilable as we can't allocate - * (unnamed) local variables to manage the internal iteration. - */ - - Tcl_Obj *objPtr = Tcl_NewObj(); - char *bytes; - int length, cmdLit; - - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); - TclEmitPush(cmdLit, envPtr); - TclDecrRefCount(objPtr); - if (localIndex >= 0) { - CompileWord(envPtr, varTokenPtr, interp, 1); - } else { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - } - CompileWord(envPtr, dataTokenPtr, interp, 2); - TclEmitInstInt1(INST_INVOKE_STK1, 3, envPtr); - goto done; - } - infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; infoPtr->firstValueTemp = dataVar; @@ -418,7 +402,6 @@ TclCompileArraySetCmd( TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); offsetFwd = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - savedStackDepth = envPtr->currStackDepth; TclEmitOpcode( INST_DUP, envPtr); Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); @@ -428,7 +411,6 @@ TclCompileArraySetCmd( TclEmitInstInt1(INST_JUMP1, back, envPtr); fwd = CurrentOffset(envPtr) - offsetFwd; TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - envPtr->currStackDepth = savedStackDepth; TclEmitOpcode( INST_POP, envPtr); } if (!isDataLiteral) { @@ -438,7 +420,7 @@ TclCompileArraySetCmd( PushStringLiteral(envPtr, ""); done: Tcl_DecrRefCount(literalObj); - return TCL_OK; + return code; } int -- cgit v0.12 From 38ae5eca7ffd791e3b3b092969700ef6ee56ba19 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 29 May 2013 14:37:58 +0000 Subject: Stop emitting the instructions INST_*_SCALAR_STK*. They are identical to their INST_*_STK* counterparts. Having done that, it is clear the "simpleVarName" return from TclPushVarName provides nothing of use to any of its callers. Eliminate that. Also make TPVN return void, instead of int. Bring the TPVN header comments up to date; they were quite rotten. --- generic/tclAssembly.c | 9 +++--- generic/tclCompCmds.c | 45 +++++++++++++++-------------- generic/tclCompCmdsGR.c | 77 ++++++++++++++++++------------------------------- generic/tclCompCmdsSZ.c | 19 ++++-------- generic/tclCompile.c | 2 +- generic/tclCompile.h | 9 +++--- 6 files changed, 67 insertions(+), 94 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index a84467f..0fe50b3a 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -387,9 +387,8 @@ static const TalInstDesc TalInstructionTable[] = { {"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1}, {"incrImm", ASSEM_LVT1_SINT1, INST_INCR_SCALAR1_IMM, 0, 1}, - {"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1}, - {"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM, - 1, 1}, + {"incrStk", ASSEM_1BYTE, INST_INCR_STK, 2, 1}, + {"incrStkImm", ASSEM_SINT1, INST_INCR_STK_IMM, 1, 1}, {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 @@ -425,7 +424,7 @@ static const TalInstDesc TalInstructionTable[] = { {"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8 | INST_LOAD_ARRAY4), 1, 1}, {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, - {"loadStk", ASSEM_1BYTE, INST_LOAD_SCALAR_STK, 1, 1}, + {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1}, {"lor", ASSEM_1BYTE, INST_LOR, 2, 1}, {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, @@ -452,7 +451,7 @@ static const TalInstDesc TalInstructionTable[] = { {"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8 | INST_STORE_ARRAY4), 2, 1}, {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, - {"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1}, + {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a966715..53b7b32 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -84,7 +84,7 @@ TclCompileAppendCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; + int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; @@ -116,7 +116,7 @@ TclCompileAppendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); /* * We are doing an assignment, otherwise TclCompileSetCmd was called, so @@ -133,7 +133,6 @@ TclCompileAppendCmd( * Emit instructions to set/get the variable. */ - if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_STK, envPtr); @@ -147,9 +146,6 @@ TclCompileAppendCmd( Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr); } } - } else { - TclEmitOpcode(INST_APPEND_STK, envPtr); - } return TCL_OK; @@ -164,7 +160,7 @@ TclCompileAppendCmd( } varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); if (!isScalar || localIndex < 0) { return TCL_ERROR; } @@ -219,7 +215,7 @@ TclCompileArrayExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int simpleVarName, isScalar, localIndex; + int isScalar, localIndex; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -227,7 +223,7 @@ TclCompileArrayExistsCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); if (!isScalar) { return TCL_ERROR; } @@ -251,7 +247,7 @@ TclCompileArraySetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *dataTokenPtr; - int simpleVarName, isScalar, localIndex, code = TCL_OK; + int isScalar, localIndex, code = TCL_OK; int isDataLiteral, isDataValid, isDataEven, len; int dataVar, iterVar, keyVar, valVar, infoIndex; int back, fwd, offsetBack, offsetFwd, savedStackDepth; @@ -293,7 +289,7 @@ TclCompileArraySetCmd( } PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); if (!isScalar) { code = TCL_ERROR; goto done; @@ -434,14 +430,14 @@ TclCompileArrayUnsetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int simpleVarName, isScalar, localIndex, savedStackDepth; + int isScalar, localIndex, savedStackDepth; if (parsePtr->numWords != 2) { return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); if (!isScalar) { return TCL_ERROR; } @@ -3246,24 +3242,33 @@ TclCompileFormatCmd( * necessary (append, lappend, set). * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * The values written to *localIndexPtr and *isScalarPtr signal to + * the caller what the instructions emitted by this routine will do: + * + * *isScalarPtr (*localIndexPtr < 0) + * 1 1 Push the varname on the stack. (Stack +1) + * 1 0 *localIndexPtr is the index of the compiled + * local for this varname. No instructions + * emitted. (Stack +0) + * 0 1 Push part1 and part2 names of array element + * on the stack. (Stack +2) + * 0 0 *localIndexPtr is the index of the compiled + * local for this array. Element name is pushed + * on the stack. (Stack +1) * * Side effects: - * Instructions are added to envPtr to execute the "set" command at - * runtime. + * Instructions are added to envPtr. * *---------------------------------------------------------------------- */ -int +void TclPushVarName( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Token *varTokenPtr, /* Points to a variable token. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ int *localIndexPtr, /* Must not be NULL. */ - int *simpleVarNamePtr, /* Must not be NULL. */ int *isScalarPtr, /* Must not be NULL. */ int line, /* Line the token starts on. */ int *clNext) /* Reference to offset of next hidden cont. @@ -3473,9 +3478,7 @@ TclPushVarName( TclStackFree(interp, elemTokenPtr); } *localIndexPtr = localIndex; - *simpleVarNamePtr = simpleVarName; *isScalarPtr = (elName == NULL); - return TCL_OK; } /* diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index c6a01e7..d101d82 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -450,7 +450,7 @@ TclCompileIncrCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *incrTokenPtr; - int simpleVarName, isScalar, localIndex, haveImmValue, immValue; + int isScalar, localIndex, haveImmValue, immValue; DefineLineInformation; /* TIP #280 */ if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { @@ -460,7 +460,7 @@ TclCompileIncrCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); /* * If an increment is given, push it, but see first if it's a small @@ -498,13 +498,7 @@ TclCompileIncrCmd( * Emit the instruction to increment the variable. */ - if (!simpleVarName) { - if (haveImmValue) { - TclEmitInstInt1( INST_INCR_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_STK, envPtr); - } - } else if (isScalar) { /* Simple scalar variable. */ + if (isScalar) { /* Simple scalar variable. */ if (localIndex >= 0) { if (haveImmValue) { TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); @@ -514,9 +508,9 @@ TclCompileIncrCmd( } } else { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); + TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); } else { - TclEmitOpcode( INST_INCR_SCALAR_STK, envPtr); + TclEmitOpcode( INST_INCR_STK, envPtr); } } } else { /* Simple array variable. */ @@ -652,7 +646,7 @@ TclCompileInfoExistsCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int isScalar, simpleVarName, localIndex; + int isScalar, localIndex; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 2) { @@ -668,16 +662,13 @@ TclCompileInfoExistsCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, - &simpleVarName, &isScalar, 1); + PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, &isScalar, 1); /* * Emit instruction to check the variable for existence. */ - if (!simpleVarName) { - TclEmitOpcode( INST_EXIST_STK, envPtr); - } else if (isScalar) { + if (isScalar) { if (localIndex < 0) { TclEmitOpcode( INST_EXIST_STK, envPtr); } else { @@ -834,7 +825,7 @@ TclCompileLappendCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i, fwd, offsetFwd; + int isScalar, localIndex, numWords, i, fwd, offsetFwd; DefineLineInformation; /* TIP #280 */ /* @@ -869,7 +860,7 @@ TclCompileLappendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); /* * If we are doing an assignment, push the new value. In the no values @@ -891,9 +882,7 @@ TclCompileLappendCmd( * LOAD/STORE instructions. */ - if (!simpleVarName) { - TclEmitOpcode( INST_LAPPEND_STK, envPtr); - } else if (isScalar) { + if (isScalar) { if (localIndex < 0) { TclEmitOpcode( INST_LAPPEND_STK, envPtr); } else { @@ -920,7 +909,7 @@ TclCompileLappendCmd( } varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); if (!isScalar || localIndex < 0) { return TCL_ERROR; } @@ -977,7 +966,7 @@ TclCompileLassignCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int simpleVarName, isScalar, localIndex, numWords, idx; + int isScalar, localIndex, numWords, idx; DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; @@ -1009,19 +998,14 @@ TclCompileLassignCmd( */ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, - &simpleVarName, &isScalar, idx+2); + &isScalar, idx+2); /* * Emit instructions to get the idx'th item out of the list value on * the stack and assign it to the variable. */ - if (!simpleVarName) { - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else if (isScalar) { + if (isScalar) { if (localIndex >= 0) { TclEmitOpcode( INST_DUP, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); @@ -1030,7 +1014,7 @@ TclCompileLassignCmd( } else { TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); + TclEmitOpcode( INST_STORE_STK, envPtr); TclEmitOpcode( INST_POP, envPtr); } } else { @@ -1607,7 +1591,6 @@ TclCompileLsetCmd( Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the variable name. */ int localIndex; /* Index of var in local var table. */ - int simpleVarName; /* Flag == 1 if var name is simple. */ int isScalar; /* Flag == 1 if scalar, 0 if array. */ int i; DefineLineInformation; /* TIP #280 */ @@ -1634,7 +1617,7 @@ TclCompileLsetCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); /* * Push the "index" args and the new element value. @@ -1649,8 +1632,8 @@ TclCompileLsetCmd( * Duplicate the variable name if it's been pushed. */ - if (!simpleVarName || localIndex < 0) { - if (!simpleVarName || isScalar) { + if (localIndex < 0) { + if (isScalar) { tempDepth = parsePtr->numWords - 2; } else { tempDepth = parsePtr->numWords - 1; @@ -1662,7 +1645,7 @@ TclCompileLsetCmd( * Duplicate an array index if one's been pushed. */ - if (simpleVarName && !isScalar) { + if (!isScalar) { if (localIndex < 0) { tempDepth = parsePtr->numWords - 1; } else { @@ -1675,11 +1658,9 @@ TclCompileLsetCmd( * Emit code to load the variable's value. */ - if (!simpleVarName) { - TclEmitOpcode( INST_LOAD_STK, envPtr); - } else if (isScalar) { + if (isScalar) { if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr); + TclEmitOpcode( INST_LOAD_STK, envPtr); } else { Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); } @@ -1705,11 +1686,9 @@ TclCompileLsetCmd( * Emit code to put the value back in the variable. */ - if (!simpleVarName) { - TclEmitOpcode( INST_STORE_STK, envPtr); - } else if (isScalar) { + if (isScalar) { if (localIndex < 0) { - TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); + TclEmitOpcode( INST_STORE_STK, envPtr); } else { Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); } @@ -1902,7 +1881,7 @@ TclCompileNamespaceUpvarCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; + int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ if (envPtr->procPtr == NULL) { @@ -1938,7 +1917,7 @@ TclCompileNamespaceUpvarCmd( CompileWord(envPtr, otherTokenPtr, interp, 1); PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); if ((localIndex < 0) || !isScalar) { return TCL_ERROR; @@ -2597,7 +2576,7 @@ TclCompileUpvarCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; + int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ Tcl_Obj *objPtr = Tcl_NewObj(); @@ -2661,7 +2640,7 @@ TclCompileUpvarCmd( CompileWord(envPtr, otherTokenPtr, interp, 1); PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); if ((localIndex < 0) || !isScalar) { return TCL_ERROR; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index f2017f0..3fb8712 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -126,7 +126,7 @@ TclCompileSetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int isAssignment, isScalar, simpleVarName, localIndex, numWords; + int isAssignment, isScalar, localIndex, numWords; DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; @@ -145,7 +145,7 @@ TclCompileSetCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); /* * If we are doing an assignment, push the new value. @@ -160,12 +160,10 @@ TclCompileSetCmd( * Emit instructions to set/get the variable. */ - if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode((isAssignment? - INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), - envPtr); + INST_STORE_STK : INST_LOAD_STK), envPtr); } else if (localIndex <= 255) { TclEmitInstInt1((isAssignment? INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), @@ -189,9 +187,6 @@ TclCompileSetCmd( localIndex, envPtr); } } - } else { - TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); - } return TCL_OK; } @@ -2683,7 +2678,7 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, simpleVarName, localIndex, numWords, flags, i; + int isScalar, localIndex, numWords, flags, i; Tcl_Obj *leadingWord; DefineLineInformation; /* TIP #280 */ @@ -2724,15 +2719,13 @@ TclCompileUnsetCmd( */ PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); /* * Emit instructions to unset the variable. */ - if (!simpleVarName) { - OP1( UNSET_STK, flags); - } else if (isScalar) { + if (isScalar) { if (localIndex < 0) { OP1( UNSET_STK, flags); } else { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 87e620c..dd179ea 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2376,7 +2376,7 @@ TclCompileVarSubst( if (tokenPtr->numComponents == 1) { if (localVar < 0) { - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + TclEmitOpcode(INST_LOAD_STK, envPtr); } else if (localVar <= 255) { TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); } else { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3909fa9..0be5d1d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -998,11 +998,10 @@ MODULE_SCOPE void TclPrintObject(FILE *outFile, Tcl_Obj *objPtr, int maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, const char *string, int maxChars); -MODULE_SCOPE int TclPushVarName(Tcl_Interp *interp, +MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr, - int line, int *clNext); + int *isScalarPtr, int line, int *clNext); MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, char *bytes, int length, int flags); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -1472,8 +1471,8 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] -#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ - TclPushVarName(i,v,e,f,l,s,sc, \ +#define PushVarNameWord(i,v,e,f,l,sc,word) \ + TclPushVarName(i,v,e,f,l,sc, \ mapPtr->loc[eclIndex].line[(word)], \ mapPtr->loc[eclIndex].next[(word)]) -- cgit v0.12 From cd0b45e3e49b8571a05590350a80980f3cc2e1b3 Mon Sep 17 00:00:00 2001 From: andreask Date: Wed, 29 May 2013 16:24:34 +0000 Subject: Fix C99 comment-ism breaking the native AIX compiler. HPUX likely as well. --- generic/tclIO.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 1b301e2..f1d8909 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6738,8 +6738,8 @@ Tcl_Tell( outputBuffered = Tcl_OutputBuffered(chan); if ((inputBuffered != 0) && (outputBuffered != 0)) { - //Tcl_SetErrno(EFAULT); - //return Tcl_LongAsWide(-1); + /*Tcl_SetErrno(EFAULT);*/ + /*return Tcl_LongAsWide(-1);*/ } /* -- cgit v0.12 From 4489ec6866f73246dd1654e0e98fc5fb431a170d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 29 May 2013 17:20:29 +0000 Subject: 3614102 - Reset stack housekeeping when compileProc fails. --- generic/tclCompile.c | 8 ++++++-- tests/compile.test | 6 ++++++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index dd179ea..039a694 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2069,9 +2069,7 @@ TclCompileScript( unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; int update = 0; -#ifdef TCL_COMPILE_DEBUG int startStackDepth = envPtr->currStackDepth; -#endif /* * Mark the start of the command; the proper bytecode @@ -2164,6 +2162,12 @@ TclCompileScript( envPtr->numCommands = savedNumCmds; envPtr->codeNext = envPtr->codeStart + savedCodeNext; + + /* + * And the stack depth too!! [Bug 3614102]. + */ + + envPtr->currStackDepth = startStackDepth; } /* diff --git a/tests/compile.test b/tests/compile.test index 4d91940..51db0a2 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -707,6 +707,12 @@ test compile-18.19 {disassembler - basics} -setup { } -cleanup { foo destroy } -match glob -result * + +test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { + # This will panic in a --enable-symbols=compile build, unless bug is fixed. + apply {{} {list [if 1]}} +} -returnCodes error -match glob -result * + # TODO sometime - check that bytecode from tbcload is *not* disassembled. # cleanup -- cgit v0.12 From 5ec1884853d19825ef0f6f5d7f85e5daec1d8e6e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 29 May 2013 20:36:05 +0000 Subject: Simplifications and tidying up of stack management issues. Work in progress. --- generic/tclCompCmds.c | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 53b7b32..7046e54 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -124,10 +124,8 @@ TclCompileAppendCmd( * each argument. */ - if (numWords > 2) { valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); - } /* * Emit instructions to set/get the variable. @@ -155,9 +153,6 @@ TclCompileAppendCmd( * there are multiple values to append. Fortunately, this is common. */ - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, &localIndex, &isScalar, 1); @@ -250,7 +245,7 @@ TclCompileArraySetCmd( int isScalar, localIndex, code = TCL_OK; int isDataLiteral, isDataValid, isDataEven, len; int dataVar, iterVar, keyVar, valVar, infoIndex; - int back, fwd, offsetBack, offsetFwd, savedStackDepth; + int back, fwd, offsetBack, offsetFwd; Tcl_Obj *literalObj; ForeachInfo *infoPtr; @@ -356,12 +351,11 @@ TclCompileArraySetCmd( TclEmitOpcode( INST_BITAND, envPtr); offsetFwd = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - savedStackDepth = envPtr->currStackDepth; PushStringLiteral(envPtr, "list must have an even number of elements"); PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); TclEmitInt4( 0, envPtr); - envPtr->currStackDepth = savedStackDepth; + TclAdjustStackDepth(-1, envPtr); fwd = CurrentOffset(envPtr) - offsetFwd; TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); } @@ -377,7 +371,6 @@ TclCompileArraySetCmd( TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); offsetFwd = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - savedStackDepth = envPtr->currStackDepth; Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); @@ -386,7 +379,6 @@ TclCompileArraySetCmd( TclEmitInstInt1(INST_JUMP1, back, envPtr); fwd = CurrentOffset(envPtr) - offsetFwd; TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - envPtr->currStackDepth = savedStackDepth; } else { TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); @@ -430,7 +422,7 @@ TclCompileArrayUnsetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int isScalar, localIndex, savedStackDepth; + int isScalar, localIndex; if (parsePtr->numWords != 2) { return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -451,10 +443,10 @@ TclCompileArrayUnsetCmd( TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); - savedStackDepth = envPtr->currStackDepth; TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); TclEmitInstInt1(INST_JUMP1, 3, envPtr); - envPtr->currStackDepth = savedStackDepth; + /* Each branch decrements stack depth, but we only take one. */ + TclAdjustStackDepth(1, envPtr); TclEmitOpcode( INST_POP, envPtr); } PushStringLiteral(envPtr, ""); @@ -497,7 +489,14 @@ TclCompileBreakCmd( */ TclEmitOpcode(INST_BREAK, envPtr); - PushStringLiteral(envPtr, ""); /* Evil hack! */ +#ifdef TCL_COMPILE_DEBUG + /* + * Instructions that raise exceptions don't really have to follow + * the usual stack management rules. But the checker wants them + * followed, so lie about stack usage to make it happy. + */ + TclAdjustStackDepth(1, envPtr); +#endif return TCL_OK; } -- cgit v0.12 From f85fd4d0e85bc96fdb38e4d2ea70ea05da1c0530 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 30 May 2013 10:29:41 +0000 Subject: Corrected code generation when doing the second run with an 'infinite' loop. --- generic/tclCompCmdsSZ.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 3fb8712..ed4d962 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2859,7 +2859,7 @@ TclCompileWhileCmd( * INST_START_CMD, and hence counted properly. [Bug 1752146] */ - envPtr->atCmdStart = 0; + envPtr->atCmdStart &= ~1; testCodeOffset = CurrentOffset(envPtr); } -- cgit v0.12 From 8430c2dada2e781cff07e2534fb7fbd11dcf1958 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 30 May 2013 10:55:39 +0000 Subject: Working towards the next batch of optimizations. --- generic/tclCompCmds.c | 81 +++++++++++++++++++++++++++++++++++++++++ generic/tclCompCmdsSZ.c | 4 +++ generic/tclCompile.c | 96 +++++++++++++++++++++++++++++++++++++++---------- generic/tclCompile.h | 6 ++++ 4 files changed, 168 insertions(+), 19 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7046e54..1f99a22 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -480,11 +480,45 @@ TclCompileBreakCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + int i, exnIdx; + ExceptionRange *rangePtr; + if (parsePtr->numWords != 1) { return TCL_ERROR; } /* + * Find the innermost exception range that contains this command. Relies + * on the fact that the range has a numCodeBytes = -1 when it is being + * populated and that inner ranges come after outer ranges. + */ + + exnIdx = -1; + for (i=0 ; iexceptArrayNext ; i++) { + rangePtr = &envPtr->exceptArrayPtr[i]; + if (envPtr->codeStart+rangePtr->codeOffset <= envPtr->codeNext + && rangePtr->numCodeBytes == -1) { + exnIdx = i; + } + } + if (exnIdx != -1) { + rangePtr = &envPtr->exceptArrayPtr[exnIdx]; + if (rangePtr->type == LOOP_EXCEPTION_RANGE) { + int toPop = envPtr->currStackDepth - + envPtr->exnStackDepthArrayPtr[exnIdx]; + + /* + * Pop off the extra stack frames. + */ + + while (toPop > 0) { + TclEmitOpcode(INST_POP, envPtr); + toPop--; + } + } + } + + /* * Emit a break instruction. */ @@ -790,6 +824,9 @@ TclCompileContinueCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + int i, exnIdx; + ExceptionRange *rangePtr; + /* * There should be no argument after the "continue". */ @@ -799,6 +836,50 @@ TclCompileContinueCmd( } /* + * See if we can find a valid continueOffset (i.e., not -1) in the + * innermost containing exception range. Relies on the fact that the range + * has a numCodeBytes = -1 when it is being populated and that inner + * ranges come after outer ranges. + */ + + exnIdx = -1; + for (i=0 ; iexceptArrayNext ; i++) { + rangePtr = &envPtr->exceptArrayPtr[i]; + if (envPtr->codeStart+rangePtr->codeOffset <= envPtr->codeNext + && rangePtr->numCodeBytes == -1) { + exnIdx = i; + } + } + if (exnIdx >= 0) { + rangePtr = &envPtr->exceptArrayPtr[exnIdx]; + if (rangePtr->type == LOOP_EXCEPTION_RANGE) { + int toPop = envPtr->currStackDepth - + envPtr->exnStackDepthArrayPtr[exnIdx]; + + /* + * Pop off the extra stack frames. + */ + + while (toPop > 0) { + TclEmitOpcode(INST_POP, envPtr); + toPop--; + } + } + if (rangePtr->type == LOOP_EXCEPTION_RANGE + && rangePtr->continueOffset != -1) { + int offset = (rangePtr->continueOffset - CurrentOffset(envPtr)); + + /* + * Found the target! No need for a nasty INST_CONTINUE here. + */ + + TclEmitInstInt4(INST_JUMP4, offset, envPtr); + PushStringLiteral(envPtr, ""); /* Evil hack! */ + return TCL_OK; + } + } + + /* * Emit a continue instruction. */ diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index ed4d962..4f4286e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2869,6 +2869,10 @@ TclCompileWhileCmd( SetLineInformation(2); bodyCodeOffset = ExceptionRangeStarts(envPtr, range); + if (!loopMayEnd) { + envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; + envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; + } CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 039a694..631ff58 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -562,7 +562,7 @@ static Command * FindCompiledCommandFromToken(Tcl_Interp *interp, static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); -static int IsCompactibleCompileEnv(Tcl_Interp *interp, +/* static */ int IsCompactibleCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr); static void PeepholeOptimize(CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS @@ -745,7 +745,9 @@ TclSetByteCodeFromAny( } compEnv.atCmdStart = 2; /* The disabling magic. */ TclCompileScript(interp, stringPtr, length, &compEnv); + assert (compEnv.atCmdStart > 1); TclEmitOpcode(INST_DONE, &compEnv); + assert (compEnv.atCmdStart > 1); } /* @@ -1034,7 +1036,7 @@ TclCleanupByteCode( * --------------------------------------------------------------------- */ -static int +/* static */ int IsCompactibleCompileEnv( Tcl_Interp *interp, CompileEnv *envPtr) @@ -1084,9 +1086,11 @@ IsCompactibleCompileEnv( case INST_NSUPVAR: case INST_VARIABLE: return 0; + default: + size = tclInstructionTable[*pc].numBytes; + assert (size > 0); + break; } - size = tclInstructionTable[*pc].numBytes; - assert (size > 0); } return 1; @@ -1145,31 +1149,39 @@ PeepholeOptimize( (void) Tcl_CreateHashEntry(&targets, (void *) target, &isNew); } break; + case INST_START_CMD: + assert (envPtr->atCmdStart < 2); } } /* - * Replace PUSH/POP sequences (when non-hazardous) with NOPs. + * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also replace + * PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an operation + * that guarantees the check for arithmeticity). */ (void) Tcl_CreateHashEntry(&targets, (void *) pc, &isNew); for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { - int blank = 0, i; + int blank = 0, i, inst; size = tclInstructionTable[*pc].numBytes; prev2 = prev1; prev1 = pc; + while (*(pc+size) == INST_NOP) { + if (Tcl_FindHashEntry(&targets, (void *) (pc + size))) { + break; + } + size += tclInstructionTable[INST_NOP].numBytes; + } if (Tcl_FindHashEntry(&targets, (void *) (pc + size))) { continue; } + inst = *(pc + size); switch (*pc) { case INST_PUSH1: - while (*(pc+size) == INST_NOP) { - size++; - } - if (*(pc+size) == INST_POP) { - blank = size + 1; - } else if (*(pc+size) == INST_CONCAT1 + if (inst == INST_POP) { + blank = size + tclInstructionTable[inst].numBytes; + } else if (inst == INST_CONCAT1 && TclGetUInt1AtPtr(pc + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt1AtPtr(pc + 1)); @@ -1177,17 +1189,14 @@ PeepholeOptimize( (void) Tcl_GetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { - blank = size + 2; + blank = size + tclInstructionTable[inst].numBytes; } } break; case INST_PUSH4: - while (*(pc+size) == INST_NOP) { - size++; - } - if (*(pc+size) == INST_POP) { + if (inst == INST_POP) { blank = size + 1; - } else if (*(pc+size) == INST_CONCAT1 + } else if (inst == INST_CONCAT1 && TclGetUInt1AtPtr(pc + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt4AtPtr(pc + 1)); @@ -1195,10 +1204,49 @@ PeepholeOptimize( (void) Tcl_GetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { - blank = size + 2; + blank = size + tclInstructionTable[inst].numBytes; } } break; + case INST_TRY_CVT_TO_NUMERIC: + switch (inst) { + case INST_JUMP_TRUE1: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE1: + case INST_JUMP_FALSE4: + case INST_INCR_SCALAR1: + case INST_INCR_ARRAY1: + case INST_INCR_ARRAY_STK: + case INST_INCR_SCALAR_STK: + case INST_INCR_STK: + case INST_LOR: + case INST_LAND: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_LE: + case INST_GT: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + blank = size; + break; + } + break; } if (blank > 0) { for (i=0 ; imallocedLiteralArray = 0; envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; + envPtr->exnStackDepthArrayPtr = envPtr->staticExnStackDepthArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; @@ -1678,6 +1727,7 @@ TclFreeCompileEnv( } if (envPtr->mallocedExceptArray) { ckfree(envPtr->exceptArrayPtr); + ckfree(envPtr->exnStackDepthArrayPtr); } if (envPtr->mallocedCmdMap) { ckfree(envPtr->cmdMapPtr); @@ -3371,12 +3421,16 @@ TclCreateExceptRange( size_t currBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); + size_t currBytes2 = envPtr->exceptArrayNext * sizeof(int); int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); + size_t newBytes2 = newElems * sizeof(int); if (envPtr->mallocedExceptArray) { envPtr->exceptArrayPtr = ckrealloc(envPtr->exceptArrayPtr, newBytes); + envPtr->exnStackDepthArrayPtr = + ckrealloc(envPtr->exnStackDepthArrayPtr, newBytes2); } else { /* * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must @@ -3384,9 +3438,12 @@ TclCreateExceptRange( */ ExceptionRange *newPtr = ckalloc(newBytes); + int *newPtr2 = ckalloc(newBytes2); memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); + memcpy(newPtr2, envPtr->exnStackDepthArrayPtr, currBytes2); envPtr->exceptArrayPtr = newPtr; + envPtr->exnStackDepthArrayPtr = newPtr2; envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayEnd = newElems; @@ -3401,6 +3458,7 @@ TclCreateExceptRange( rangePtr->breakOffset = -1; rangePtr->continueOffset = -1; rangePtr->catchOffset = -1; + envPtr->exnStackDepthArrayPtr[index] = envPtr->currStackDepth; return index; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 0be5d1d..c380823 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -275,6 +275,9 @@ typedef struct CompileEnv { * entry. */ int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ + int *exnStackDepthArrayPtr; /* Array of stack depths to restore to when + * processing BREAK/CONTINUE exceptions. Must + * be the same size as the exceptArrayPtr. */ CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. * numCommands is the index of the next entry * to use; (numCommands-1) is the entry index @@ -296,6 +299,9 @@ typedef struct CompileEnv { /* Initial storage of LiteralEntry array. */ ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial ExceptionRange array storage. */ + int staticExnStackDepthArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; + /* Initial static except stack depth array + * storage. */ CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; /* Initial storage for cmd location map. */ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; -- cgit v0.12 From 8d03d462d4d27ee4a2d6fec72a8d2efe9e90f94a Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 30 May 2013 10:57:13 +0000 Subject: derp --- generic/tclCompile.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 631ff58..54946ee 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -562,7 +562,7 @@ static Command * FindCompiledCommandFromToken(Tcl_Interp *interp, static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); -/* static */ int IsCompactibleCompileEnv(Tcl_Interp *interp, +static int IsCompactibleCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr); static void PeepholeOptimize(CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS @@ -1036,7 +1036,7 @@ TclCleanupByteCode( * --------------------------------------------------------------------- */ -/* static */ int +static int IsCompactibleCompileEnv( Tcl_Interp *interp, CompileEnv *envPtr) -- cgit v0.12 From d09727e7ff46a2abd069caac727159c92f6c9436 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 1 Jun 2013 21:05:55 +0000 Subject: Getting better at doing more efficient break/continue instruction handling. --- generic/tclCompCmds.c | 113 ++++++++++++++++++++++++++++---------------------- generic/tclCompile.c | 42 +++++++++++++++++++ generic/tclCompile.h | 6 +++ 3 files changed, 111 insertions(+), 50 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 1f99a22..6e5d187 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -480,7 +480,7 @@ TclCompileBreakCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int i, exnIdx; + int depth; ExceptionRange *rangePtr; if (parsePtr->numWords != 1) { @@ -488,33 +488,40 @@ TclCompileBreakCmd( } /* - * Find the innermost exception range that contains this command. Relies - * on the fact that the range has a numCodeBytes = -1 when it is being - * populated and that inner ranges come after outer ranges. + * Find the innermost exception range that contains this command. */ - exnIdx = -1; - for (i=0 ; iexceptArrayNext ; i++) { - rangePtr = &envPtr->exceptArrayPtr[i]; - if (envPtr->codeStart+rangePtr->codeOffset <= envPtr->codeNext - && rangePtr->numCodeBytes == -1) { - exnIdx = i; + rangePtr = TclGetInnermostExceptionRange(envPtr, &depth); + if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { + int toPop = envPtr->currStackDepth - depth; + + /* + * Pop off the extra stack frames. + */ + + while (toPop > 0) { + TclEmitOpcode(INST_POP, envPtr); + toPop--; +#ifdef TCL_COMPILE_DEBUG + /* + * Instructions that raise exceptions don't really have to follow + * the usual stack management rules. But the checker wants them + * followed, so lie about stack usage to make it happy. + */ + TclAdjustStackDepth(1, envPtr); +#endif } - } - if (exnIdx != -1) { - rangePtr = &envPtr->exceptArrayPtr[exnIdx]; - if (rangePtr->type == LOOP_EXCEPTION_RANGE) { - int toPop = envPtr->currStackDepth - - envPtr->exnStackDepthArrayPtr[exnIdx]; + + if (envPtr->expandCount == 0 && rangePtr->breakOffset != -1) { + int offset = (rangePtr->breakOffset - CurrentOffset(envPtr)); /* - * Pop off the extra stack frames. + * Found the target! Also, no built-up expansion stack. No need + * for a nasty INST_BREAK here. */ - while (toPop > 0) { - TclEmitOpcode(INST_POP, envPtr); - toPop--; - } + TclEmitInstInt4(INST_JUMP4, offset, envPtr); + goto done; } } @@ -523,6 +530,8 @@ TclCompileBreakCmd( */ TclEmitOpcode(INST_BREAK, envPtr); + + done: #ifdef TCL_COMPILE_DEBUG /* * Instructions that raise exceptions don't really have to follow @@ -824,7 +833,7 @@ TclCompileContinueCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int i, exnIdx; + int depth; ExceptionRange *rangePtr; /* @@ -837,45 +846,40 @@ TclCompileContinueCmd( /* * See if we can find a valid continueOffset (i.e., not -1) in the - * innermost containing exception range. Relies on the fact that the range - * has a numCodeBytes = -1 when it is being populated and that inner - * ranges come after outer ranges. + * innermost containing exception range. */ - exnIdx = -1; - for (i=0 ; iexceptArrayNext ; i++) { - rangePtr = &envPtr->exceptArrayPtr[i]; - if (envPtr->codeStart+rangePtr->codeOffset <= envPtr->codeNext - && rangePtr->numCodeBytes == -1) { - exnIdx = i; - } - } - if (exnIdx >= 0) { - rangePtr = &envPtr->exceptArrayPtr[exnIdx]; - if (rangePtr->type == LOOP_EXCEPTION_RANGE) { - int toPop = envPtr->currStackDepth - - envPtr->exnStackDepthArrayPtr[exnIdx]; + rangePtr = TclGetInnermostExceptionRange(envPtr, &depth); + if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { + int toPop = envPtr->currStackDepth - depth; + + /* + * Pop off the extra stack frames. + */ + while (toPop > 0) { + TclEmitOpcode(INST_POP, envPtr); + toPop--; +#ifdef TCL_COMPILE_DEBUG /* - * Pop off the extra stack frames. + * Instructions that raise exceptions don't really have to follow + * the usual stack management rules. But the checker wants them + * followed, so lie about stack usage to make it happy. */ - - while (toPop > 0) { - TclEmitOpcode(INST_POP, envPtr); - toPop--; - } + TclAdjustStackDepth(1, envPtr); +#endif } - if (rangePtr->type == LOOP_EXCEPTION_RANGE - && rangePtr->continueOffset != -1) { + + if (envPtr->expandCount == 0 && rangePtr->continueOffset != -1) { int offset = (rangePtr->continueOffset - CurrentOffset(envPtr)); /* - * Found the target! No need for a nasty INST_CONTINUE here. + * Found the target! Also, no built-up expansion stack. No need + * for a nasty INST_CONTINUE here. */ TclEmitInstInt4(INST_JUMP4, offset, envPtr); - PushStringLiteral(envPtr, ""); /* Evil hack! */ - return TCL_OK; + goto done; } } @@ -884,7 +888,16 @@ TclCompileContinueCmd( */ TclEmitOpcode(INST_CONTINUE, envPtr); - PushStringLiteral(envPtr, ""); /* Evil hack! */ + + done: +#ifdef TCL_COMPILE_DEBUG + /* + * Instructions that raise exceptions don't really have to follow + * the usual stack management rules. But the checker wants them + * followed, so lie about stack usage to make it happy. + */ + TclAdjustStackDepth(1, envPtr); +#endif return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 54946ee..c56b67f 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1523,6 +1523,7 @@ TclInitCompileEnv( envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; envPtr->atCmdStart = 1; + envPtr->expandCount = 0; /* * TIP #280: Set up the extended command location information, based on @@ -2060,6 +2061,7 @@ TclCompileScript( if (expand) { TclEmitOpcode(INST_EXPAND_START, envPtr); + envPtr->expandCount++; } /* @@ -2279,6 +2281,7 @@ TclCompileScript( */ TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; TclAdjustStackDepth(1 - wordIdx, envPtr); } else if (wordIdx > 0) { /* @@ -3463,6 +3466,45 @@ TclCreateExceptRange( } /* + * --------------------------------------------------------------------- + * + * TclGetInnermostExceptionRange -- + * + * Returns the innermost exception range that covers the current code + * creation point, and (optionally) the stack depth that is expected at + * that point. Relies on the fact that the range has a numCodeBytes = -1 + * when it is being populated and that inner ranges come after outer + * ranges. + * + * --------------------------------------------------------------------- + */ + +ExceptionRange * +TclGetInnermostExceptionRange( + CompileEnv *envPtr, + int *stackDepthPtr) +{ + int exnIdx = -1, i; + + for (i=0 ; iexceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + + if (CurrentOffset(envPtr) >= rangePtr->codeOffset && + (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) < + rangePtr->codeOffset+rangePtr->numCodeBytes)) { + exnIdx = i; + } + } + if (exnIdx == -1) { + return NULL; + } + if (stackDepthPtr) { + *stackDepthPtr = envPtr->exnStackDepthArrayPtr[exnIdx]; + } + return &envPtr->exceptArrayPtr[exnIdx]; +} + +/* *---------------------------------------------------------------------- * * TclCreateAuxData -- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c380823..c9cbbd4 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -318,6 +318,10 @@ typedef struct CompileEnv { * inefficient. If set to 2, that instruction * should not be issued at all (by the generic * part of the command compiler). */ + int expandCount; /* Number of INST_EXPAND_START instructions + * encountered that have not yet been paired + * with a corresponding + * INST_INVOKE_EXPANDED. */ ContLineLoc *clLoc; /* If not NULL, the table holding the * locations of the invisible continuation * lines in the input script, to adjust the @@ -990,6 +994,8 @@ MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, int numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); +MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, + int *depthPtr); #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); -- cgit v0.12 From 8bd69e27f28e6a4927f6df9aacd29694d76c0dca Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 2 Jun 2013 17:41:14 +0000 Subject: Many improvements to code generation of efficient break and continue. --- generic/tclCompCmds.c | 93 +++++++++++----------------- generic/tclCompCmdsSZ.c | 11 ++-- generic/tclCompile.c | 160 ++++++++++++++++++++++++++++++++++++++++++++---- generic/tclCompile.h | 52 ++++++++++++++-- 4 files changed, 235 insertions(+), 81 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6e5d187..f2d2963 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -480,8 +480,8 @@ TclCompileBreakCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int depth; ExceptionRange *rangePtr; + ExceptionAux *auxPtr; if (parsePtr->numWords != 1) { return TCL_ERROR; @@ -491,9 +491,9 @@ TclCompileBreakCmd( * Find the innermost exception range that contains this command. */ - rangePtr = TclGetInnermostExceptionRange(envPtr, &depth); + rangePtr = TclGetInnermostExceptionRange(envPtr, &auxPtr); if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - int toPop = envPtr->currStackDepth - depth; + int toPop = envPtr->currStackDepth - auxPtr->stackDepth; /* * Pop off the extra stack frames. @@ -501,26 +501,18 @@ TclCompileBreakCmd( while (toPop > 0) { TclEmitOpcode(INST_POP, envPtr); - toPop--; -#ifdef TCL_COMPILE_DEBUG - /* - * Instructions that raise exceptions don't really have to follow - * the usual stack management rules. But the checker wants them - * followed, so lie about stack usage to make it happy. - */ TclAdjustStackDepth(1, envPtr); -#endif + toPop--; } - if (envPtr->expandCount == 0 && rangePtr->breakOffset != -1) { - int offset = (rangePtr->breakOffset - CurrentOffset(envPtr)); - + if (envPtr->expandCount == 0) { /* * Found the target! Also, no built-up expansion stack. No need * for a nasty INST_BREAK here. */ - TclEmitInstInt4(INST_JUMP4, offset, envPtr); + TclAddLoopBreakFixup(envPtr, auxPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); goto done; } } @@ -532,14 +524,12 @@ TclCompileBreakCmd( TclEmitOpcode(INST_BREAK, envPtr); done: -#ifdef TCL_COMPILE_DEBUG /* - * Instructions that raise exceptions don't really have to follow - * the usual stack management rules. But the checker wants them - * followed, so lie about stack usage to make it happy. + * Instructions that raise exceptions don't really have to follow the + * usual stack management rules, but the cleanup code does. */ + TclAdjustStackDepth(1, envPtr); -#endif return TCL_OK; } @@ -645,7 +635,7 @@ TclCompileCatchCmd( * uses. */ - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); /* * If the body is a simple word, compile a BEGIN_CATCH instruction, @@ -833,8 +823,8 @@ TclCompileContinueCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int depth; ExceptionRange *rangePtr; + ExceptionAux *auxPtr; /* * There should be no argument after the "continue". @@ -849,9 +839,9 @@ TclCompileContinueCmd( * innermost containing exception range. */ - rangePtr = TclGetInnermostExceptionRange(envPtr, &depth); + rangePtr = TclGetInnermostExceptionRange(envPtr, &auxPtr); if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - int toPop = envPtr->currStackDepth - depth; + int toPop = envPtr->currStackDepth - auxPtr->stackDepth; /* * Pop off the extra stack frames. @@ -859,26 +849,18 @@ TclCompileContinueCmd( while (toPop > 0) { TclEmitOpcode(INST_POP, envPtr); - toPop--; -#ifdef TCL_COMPILE_DEBUG - /* - * Instructions that raise exceptions don't really have to follow - * the usual stack management rules. But the checker wants them - * followed, so lie about stack usage to make it happy. - */ TclAdjustStackDepth(1, envPtr); -#endif + toPop--; } - if (envPtr->expandCount == 0 && rangePtr->continueOffset != -1) { - int offset = (rangePtr->continueOffset - CurrentOffset(envPtr)); - + if (envPtr->expandCount == 0) { /* * Found the target! Also, no built-up expansion stack. No need * for a nasty INST_CONTINUE here. */ - TclEmitInstInt4(INST_JUMP4, offset, envPtr); + TclAddLoopContinueFixup(envPtr, auxPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); goto done; } } @@ -890,14 +872,12 @@ TclCompileContinueCmd( TclEmitOpcode(INST_CONTINUE, envPtr); done: -#ifdef TCL_COMPILE_DEBUG /* - * Instructions that raise exceptions don't really have to follow - * the usual stack management rules. But the checker wants them - * followed, so lie about stack usage to make it happy. + * Instructions that raise exceptions don't really have to follow the + * usual stack management rules, but the cleanup code does. */ + TclAdjustStackDepth(1, envPtr); -#endif return TCL_OK; } @@ -1350,7 +1330,7 @@ TclCompileDictMergeCmd( * For each of the remaining dictionaries... */ - outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); ExceptionRangeStarts(envPtr, outLoop); for (i=2 ; inumWords ; i++) { @@ -1563,7 +1543,7 @@ CompileDictEachCmd( * started by Tcl_DictObjFirst above. */ - catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); ExceptionRangeStarts(envPtr, catchRange); @@ -1581,7 +1561,7 @@ CompileDictEachCmd( * Set up the loop exception targets. */ - loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); ExceptionRangeStarts(envPtr, loopRange); /* @@ -1629,6 +1609,7 @@ CompileDictEachCmd( */ ExceptionRangeTarget(envPtr, loopRange, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, loopRange); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); @@ -1807,7 +1788,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); TclEmitInt4( infoIndex, envPtr); - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -2164,7 +2145,7 @@ TclCompileDictWithCmd( * Now the body of the [dict with]. */ - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -2446,15 +2427,6 @@ TclCompileForCmd( } /* - * Create ExceptionRange records for the body and the "next" command. The - * "next" command's ExceptionRange supports break but not continue (and - * has a -1 continueOffset). - */ - - bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); - nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - - /* * Inline compile the initial command. */ @@ -2480,6 +2452,7 @@ TclCompileForCmd( * Compile the loop body. */ + bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); SetLineInformation(4); CompileBody(envPtr, bodyTokenPtr, interp); @@ -2488,9 +2461,12 @@ TclCompileForCmd( TclEmitOpcode(INST_POP, envPtr); /* - * Compile the "next" subcommand. + * Compile the "next" subcommand. Note that this exception range will not + * have a continueOffset (other than -1) connected to it; it won't trap + * TCL_CONTINUE but rather just TCL_BREAK. */ + nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->currStackDepth = savedStackDepth; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); SetLineInformation(3); @@ -2538,6 +2514,8 @@ TclCompileForCmd( ExceptionRangeTarget(envPtr, bodyRange, breakOffset); ExceptionRangeTarget(envPtr, nextRange, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, bodyRange); + TclFinalizeLoopExceptionRange(envPtr, nextRange); /* * The for command's result is an empty string. @@ -2829,7 +2807,7 @@ CompileEachloopCmd( * Create an exception record to handle [break] and [continue]. */ - range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * Evaluate then store each value list in the associated temporary. @@ -2935,6 +2913,7 @@ CompileEachloopCmd( */ ExceptionRangeTarget(envPtr, range, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, range); /* * The command's result is an empty string if not collecting, or the diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 4f4286e..721f59a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -834,7 +834,7 @@ TclSubstCompile( } envPtr->line = bline; - catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, catchRange); ExceptionRangeStarts(envPtr, catchRange); @@ -2302,7 +2302,7 @@ IssueTryInstructions( * (and it's never called when there's a finally clause). */ - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); BODY( bodyToken, 1); @@ -2455,7 +2455,7 @@ IssueTryFinallyInstructions( * (if any trap matches) and run a finally clause. */ - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); envPtr->currStackDepth = savedStackDepth; @@ -2522,7 +2522,7 @@ IssueTryFinallyInstructions( */ if (resultVars[i] >= 0 || handlerTokens[i]) { - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); } @@ -2833,7 +2833,7 @@ TclCompileWhileCmd( * implement break and continue. */ - range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * Jump to the evaluation of the condition. This code uses the "loop @@ -2917,6 +2917,7 @@ TclCompileWhileCmd( envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; ExceptionRangeTarget(envPtr, range, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, range); /* * The while command's result is an empty string. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c56b67f..96f8683 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1514,7 +1514,7 @@ TclInitCompileEnv( envPtr->mallocedLiteralArray = 0; envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; - envPtr->exnStackDepthArrayPtr = envPtr->staticExnStackDepthArraySpace; + envPtr->exceptAuxArrayPtr = envPtr->staticExAuxArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; @@ -1728,7 +1728,7 @@ TclFreeCompileEnv( } if (envPtr->mallocedExceptArray) { ckfree(envPtr->exceptArrayPtr); - ckfree(envPtr->exnStackDepthArrayPtr); + ckfree(envPtr->exceptAuxArrayPtr); } if (envPtr->mallocedCmdMap) { ckfree(envPtr->cmdMapPtr); @@ -3413,6 +3413,7 @@ TclCreateExceptRange( * new ExceptionRange structure. */ { register ExceptionRange *rangePtr; + register ExceptionAux *auxPtr; int index = envPtr->exceptArrayNext; if (index >= envPtr->exceptArrayEnd) { @@ -3424,16 +3425,16 @@ TclCreateExceptRange( size_t currBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); - size_t currBytes2 = envPtr->exceptArrayNext * sizeof(int); + size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux); int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); - size_t newBytes2 = newElems * sizeof(int); + size_t newBytes2 = newElems * sizeof(ExceptionAux); if (envPtr->mallocedExceptArray) { envPtr->exceptArrayPtr = ckrealloc(envPtr->exceptArrayPtr, newBytes); - envPtr->exnStackDepthArrayPtr = - ckrealloc(envPtr->exnStackDepthArrayPtr, newBytes2); + envPtr->exceptAuxArrayPtr = + ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2); } else { /* * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must @@ -3441,12 +3442,12 @@ TclCreateExceptRange( */ ExceptionRange *newPtr = ckalloc(newBytes); - int *newPtr2 = ckalloc(newBytes2); + ExceptionAux *newPtr2 = ckalloc(newBytes2); memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); - memcpy(newPtr2, envPtr->exnStackDepthArrayPtr, currBytes2); + memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2); envPtr->exceptArrayPtr = newPtr; - envPtr->exnStackDepthArrayPtr = newPtr2; + envPtr->exceptAuxArrayPtr = newPtr2; envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayEnd = newElems; @@ -3461,7 +3462,14 @@ TclCreateExceptRange( rangePtr->breakOffset = -1; rangePtr->continueOffset = -1; rangePtr->catchOffset = -1; - envPtr->exnStackDepthArrayPtr[index] = envPtr->currStackDepth; + auxPtr = &envPtr->exceptAuxArrayPtr[index]; + auxPtr->stackDepth = envPtr->currStackDepth; + auxPtr->numBreakTargets = 0; + auxPtr->breakTargets = NULL; + auxPtr->allocBreakTargets = 0; + auxPtr->numContinueTargets = 0; + auxPtr->continueTargets = NULL; + auxPtr->allocContinueTargets = 0; return index; } @@ -3482,7 +3490,7 @@ TclCreateExceptRange( ExceptionRange * TclGetInnermostExceptionRange( CompileEnv *envPtr, - int *stackDepthPtr) + ExceptionAux **auxPtrPtr) { int exnIdx = -1, i; @@ -3498,12 +3506,122 @@ TclGetInnermostExceptionRange( if (exnIdx == -1) { return NULL; } - if (stackDepthPtr) { - *stackDepthPtr = envPtr->exnStackDepthArrayPtr[exnIdx]; + if (auxPtrPtr) { + *auxPtrPtr = &envPtr->exceptAuxArrayPtr[exnIdx]; } return &envPtr->exceptArrayPtr[exnIdx]; } +void +TclAddLoopBreakFixup( + CompileEnv *envPtr, + ExceptionAux *auxPtr) +{ + int range = auxPtr - envPtr->exceptAuxArrayPtr; + + if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { + Tcl_Panic("trying to add 'break' fixup to full exception range"); + } + + if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) { + auxPtr->allocBreakTargets *= 2; + auxPtr->allocBreakTargets += 2; + if (auxPtr->breakTargets) { + auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets, + sizeof(int) * auxPtr->allocBreakTargets); + } else { + auxPtr->breakTargets = + ckalloc(sizeof(int) * auxPtr->allocBreakTargets); + } + } + auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); +} + +void +TclAddLoopContinueFixup( + CompileEnv *envPtr, + ExceptionAux *auxPtr) +{ + int range = auxPtr - envPtr->exceptAuxArrayPtr; + + if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { + Tcl_Panic("trying to add 'continue' fixup to full exception range"); + } + + if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) { + auxPtr->allocContinueTargets *= 2; + auxPtr->allocContinueTargets += 2; + if (auxPtr->continueTargets) { + auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets, + sizeof(int) * auxPtr->allocContinueTargets); + } else { + auxPtr->continueTargets = + ckalloc(sizeof(int) * auxPtr->allocContinueTargets); + } + } + auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = + CurrentOffset(envPtr); +} + +void +TclFinalizeLoopExceptionRange( + CompileEnv *envPtr, + int range) +{ + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range]; + ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range]; + int i, offset; + unsigned char *site; + + if (rangePtr->type != LOOP_EXCEPTION_RANGE) { + Tcl_Panic("trying to finalize a loop exception range"); + } + + /* + * Do the jump fixups. Note that these are always issued as INST_JUMP4 so + * there is no need to fuss around with updating code offsets. + */ + + for (i=0 ; inumBreakTargets ; i++) { + site = envPtr->codeStart + auxPtr->breakTargets[i]; + offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; + TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); + } + for (i=0 ; inumContinueTargets ; i++) { + site = envPtr->codeStart + auxPtr->continueTargets[i]; + if (rangePtr->continueOffset == -1) { + int j; + + /* + * WTF? Can't bind, so revert to an INST_CONTINUE. + */ + + *site = INST_CONTINUE; + for (j=0 ; j<4 ; j++) { + *++site = INST_NOP; + } + } else { + offset = rangePtr->continueOffset - auxPtr->continueTargets[i]; + TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); + } + } + + /* + * Drop the arrays we were holding the only reference to. + */ + + if (auxPtr->breakTargets) { + ckfree(auxPtr->breakTargets); + auxPtr->breakTargets = NULL; + auxPtr->numBreakTargets = 0; + } + if (auxPtr->continueTargets) { + ckfree(auxPtr->continueTargets); + auxPtr->continueTargets = NULL; + auxPtr->numContinueTargets = 0; + } +} + /* *---------------------------------------------------------------------- * @@ -3864,6 +3982,22 @@ TclFixupForwardJump( } } + for (k = 0 ; k < envPtr->exceptArrayNext ; k++) { + ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; + int i; + + for (i=0 ; inumBreakTargets ; i++) { + if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) { + auxPtr->breakTargets[i] += 3; + } + } + for (i=0 ; inumContinueTargets ; i++) { + if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) { + auxPtr->continueTargets[i] += 3; + } + } + } + /* * TIP #280: Adjust the mapping from PC values to the per-command * information about arguments and their line numbers. diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c9cbbd4..8430da3 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -100,6 +100,38 @@ typedef struct ExceptionRange { } ExceptionRange; /* + * Auxiliary data used when issuing (currently just loop) exception ranges, + * but which is not required during execution. + */ + +typedef struct ExceptionAux { + int stackDepth; /* The stack depth at the point where the + * exception range was created. This is used + * to calculate the number of POPs required to + * restore the stack to its prior state. */ + int numBreakTargets; /* The number of [break]s that want to be + * targeted to the place where this loop + * exception will be bound to. */ + int *breakTargets; /* The offsets of the INST_JUMP4 instructions + * issued by the [break]s that we must + * update. Note that resizing a jump (via + * TclFixupForwardJump) can cause the contents + * of this array to be updated. When + * numBreakTargets==0, this is NULL. */ + int allocBreakTargets; /* The size of the breakTargets array. */ + int numContinueTargets; /* The number of [continue]s that want to be + * targeted to the place where this loop + * exception will be bound to. */ + int *continueTargets; /* The offsets of the INST_JUMP4 instructions + * issued by the [continue]s that we must + * update. Note that resizing a jump (via + * TclFixupForwardJump) can cause the contents + * of this array to be updated. When + * numContinueTargets==0, this is NULL. */ + int allocContinueTargets; /* The size of the continueTargets array. */ +} ExceptionAux; + +/* * Structure used to map between instruction pc and source locations. It * defines for each compiled Tcl command its code's starting offset and its * source's starting offset and length. Note that the code offset increases @@ -275,9 +307,11 @@ typedef struct CompileEnv { * entry. */ int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ - int *exnStackDepthArrayPtr; /* Array of stack depths to restore to when - * processing BREAK/CONTINUE exceptions. Must - * be the same size as the exceptArrayPtr. */ + ExceptionAux *exceptAuxArrayPtr; + /* Array of information used to restore the + * state when processing BREAK/CONTINUE + * exceptions. Must be the same size as the + * exceptArrayPtr. */ CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. * numCommands is the index of the next entry * to use; (numCommands-1) is the entry index @@ -299,8 +333,8 @@ typedef struct CompileEnv { /* Initial storage of LiteralEntry array. */ ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial ExceptionRange array storage. */ - int staticExnStackDepthArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; - /* Initial static except stack depth array + ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; + /* Initial static except auxiliary info array * storage. */ CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; /* Initial storage for cmd location map. */ @@ -995,7 +1029,13 @@ MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, - int *depthPtr); + ExceptionAux **auxPtrPtr); +MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr, + ExceptionAux *auxPtr); +MODULE_SCOPE void TclAddLoopContinueFixup(CompileEnv *envPtr, + ExceptionAux *auxPtr); +MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, + int range); #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); -- cgit v0.12 From 77f3ad2fcd5b1383a5a9e38441c20bbb4227fd03 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 2 Jun 2013 18:54:09 +0000 Subject: Remove useless macro, use existing macro where it makes sense. --- generic/tclAssembly.c | 4 ++-- generic/tclCompile.h | 3 --- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 0fe50b3a..d1af8c6 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -650,7 +650,7 @@ BBEmitOpcode( } TclEmitInt1(op, envPtr); - envPtr->atCmdStart = ((op) == INST_START_CMD); + TclUpdateAtCmdStart(op, envPtr); BBUpdateStackReqs(bbPtr, tblIdx, count); } @@ -711,7 +711,7 @@ BBEmitInst1or4( } else { TclEmitInt4(param, envPtr); } - envPtr->atCmdStart = ((op) == INST_START_CMD); + TclUpdateAtCmdStart(op, envPtr); BBUpdateStackReqs(bbPtr, tblIdx, count); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 8430da3..4b50710 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1450,14 +1450,11 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); * of LOOP ranges is an interesting datum for debugging purposes, and that is * what we compute now. * - * static int DeclareExceptionRange(CompileEnv *envPtr, int type); * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); */ -#define DeclareExceptionRange(envPtr, type) \ - (TclCreateExceptRange((type), (envPtr))) #define ExceptionRangeStarts(envPtr, index) \ (((envPtr)->exceptDepth++), \ ((envPtr)->maxExceptDepth = \ -- cgit v0.12 From c72504b5e8f17039d8438be6e3f41d5b8e2928eb Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 2 Jun 2013 21:32:16 +0000 Subject: Fix a stack depth calculation. --- generic/tclCompCmdsSZ.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 721f59a..7831198 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1518,7 +1518,7 @@ IssueSwitchChainedTests( */ OP( POP); - envPtr->currStackDepth = savedStackDepth + 1; + envPtr->currStackDepth = savedStackDepth; envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); -- cgit v0.12 From ae411458670d6ca50c9516ed742f9b06855637a9 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 3 Jun 2013 09:37:14 +0000 Subject: Generate [continue] optimally in [for] next clauses. Add tests for Bug 3614226. --- generic/tclCompCmds.c | 11 ++++---- generic/tclCompile.c | 35 +++++++++++++++++++++++- generic/tclCompile.h | 13 ++++++++- tests/for.test | 74 ++++++++++++++++++++++++++++++++++++++++++++++----- 4 files changed, 119 insertions(+), 14 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index f2d2963..3046841 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -491,7 +491,7 @@ TclCompileBreakCmd( * Find the innermost exception range that contains this command. */ - rangePtr = TclGetInnermostExceptionRange(envPtr, &auxPtr); + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr); if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { int toPop = envPtr->currStackDepth - auxPtr->stackDepth; @@ -505,14 +505,13 @@ TclCompileBreakCmd( toPop--; } - if (envPtr->expandCount == 0) { + if (envPtr->expandCount == auxPtr->expandTarget) { /* * Found the target! Also, no built-up expansion stack. No need * for a nasty INST_BREAK here. */ TclAddLoopBreakFixup(envPtr, auxPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); goto done; } } @@ -839,7 +838,7 @@ TclCompileContinueCmd( * innermost containing exception range. */ - rangePtr = TclGetInnermostExceptionRange(envPtr, &auxPtr); + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr); if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { int toPop = envPtr->currStackDepth - auxPtr->stackDepth; @@ -853,14 +852,13 @@ TclCompileContinueCmd( toPop--; } - if (envPtr->expandCount == 0) { + if (envPtr->expandCount == auxPtr->expandTarget) { /* * Found the target! Also, no built-up expansion stack. No need * for a nasty INST_CONTINUE here. */ TclAddLoopContinueFixup(envPtr, auxPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); goto done; } } @@ -2467,6 +2465,7 @@ TclCompileForCmd( */ nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; envPtr->currStackDepth = savedStackDepth; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); SetLineInformation(3); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 96f8683..f2e9329 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3463,7 +3463,9 @@ TclCreateExceptRange( rangePtr->continueOffset = -1; rangePtr->catchOffset = -1; auxPtr = &envPtr->exceptAuxArrayPtr[index]; + auxPtr->supportsContinue = 1; auxPtr->stackDepth = envPtr->currStackDepth; + auxPtr->expandTarget = envPtr->expandCount; auxPtr->numBreakTargets = 0; auxPtr->breakTargets = NULL; auxPtr->allocBreakTargets = 0; @@ -3490,6 +3492,7 @@ TclCreateExceptRange( ExceptionRange * TclGetInnermostExceptionRange( CompileEnv *envPtr, + int returnCode, ExceptionAux **auxPtrPtr) { int exnIdx = -1, i; @@ -3499,7 +3502,9 @@ TclGetInnermostExceptionRange( if (CurrentOffset(envPtr) >= rangePtr->codeOffset && (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) < - rangePtr->codeOffset+rangePtr->numCodeBytes)) { + rangePtr->codeOffset+rangePtr->numCodeBytes) && + (returnCode != TCL_CONTINUE || + envPtr->exceptAuxArrayPtr[i].supportsContinue)) { exnIdx = i; } } @@ -3512,6 +3517,19 @@ TclGetInnermostExceptionRange( return &envPtr->exceptArrayPtr[exnIdx]; } +/* + * --------------------------------------------------------------------- + * + * TclAddLoopBreakFixup, TclAddLoopContinueFixup -- + * + * Adds a place that wants to break/continue to the loop exception range + * tracking that will be fixed up once the loop can be finalized. These + * functions will generate an INST_JUMP4 that will be fixed up during the + * loop finalization. + * + * --------------------------------------------------------------------- + */ + void TclAddLoopBreakFixup( CompileEnv *envPtr, @@ -3535,6 +3553,7 @@ TclAddLoopBreakFixup( } } auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); } void @@ -3561,7 +3580,21 @@ TclAddLoopContinueFixup( } auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = CurrentOffset(envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); } + +/* + * --------------------------------------------------------------------- + * + * TclFinalizeLoopExceptionRange -- + * + * Finalizes a loop exception range, binding the registered [break] and + * [continue] implementations so that they jump to the correct place. + * Note that this must only be called after *all* the exception range + * target offsets have been set. + * + * --------------------------------------------------------------------- + */ void TclFinalizeLoopExceptionRange( diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 4b50710..957c724 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -105,10 +105,21 @@ typedef struct ExceptionRange { */ typedef struct ExceptionAux { + int supportsContinue; /* Whether this exception range will have a + * continueOffset created for it; if it is a + * loop exception range that *doesn't* have + * one (see [for] next-clause) then we must + * not pick up the range when scanning for a + * target to continue to. */ int stackDepth; /* The stack depth at the point where the * exception range was created. This is used * to calculate the number of POPs required to * restore the stack to its prior state. */ + int expandTarget; /* The number of expansions expected on the + * auxData stack at the time the loop starts; + * we can't currently discard them except by + * doing INST_INVOKE_EXPANDED; this is a known + * problem. */ int numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ @@ -1029,7 +1040,7 @@ MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, - ExceptionAux **auxPtrPtr); + int returnCode, ExceptionAux **auxPtrPtr); MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclAddLoopContinueFixup(CompileEnv *envPtr, diff --git a/tests/for.test b/tests/for.test index ff4dc0e..3f4d2b7 100644 --- a/tests/for.test +++ b/tests/for.test @@ -14,6 +14,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +# Used for constraining memory leak tests +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc meminfo {} {lindex [split [memory info] "\n"] 3 3} +} + # Basic "for" operation. test for-1.1 {TclCompileForCmd: missing initial command} { @@ -345,7 +351,6 @@ proc formatMail {} { 64 { UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \ 65 { binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \ } - set result "" set NL " " @@ -365,7 +370,6 @@ proc formatMail {} { } else { set break 1 } - set xmailer 0 set inheaders 1 set last [array size lines] @@ -386,9 +390,7 @@ proc formatMail {} { set limit 55 } else { set limit 55 - # Decide whether or not to break the body line - if {$plen > 0} { if {[string first {> } $line] == 0} { # This is quoted text from previous message, don't reformat @@ -431,7 +433,7 @@ proc formatMail {} { set climit [expr $limit-1] set cutoff 50 set continuation 0 - + while {[string length $line] > $limit} { for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} { set char [string index $line $c] @@ -824,7 +826,67 @@ test for-6.18 {Tcl_ForObjCmd: for command result} { 1 {invoked "continue" outside of a loop} \ ] - +test for-7.1 {Bug 3614226: ensure that break cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [break] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.2 {Bug 3614226: ensure that continue cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [continue] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} {memory knownBug} { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[break] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} {memory knownBug} { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[continue] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From 69c9746bd1fb5d903ee327444835805a4a99786f Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 3 Jun 2013 14:01:24 +0000 Subject: Improve reliability of test httpold-4.12. Thanks AF! --- tests/httpd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/httpd b/tests/httpd index 3ea8024..7ba07af 100644 --- a/tests/httpd +++ b/tests/httpd @@ -39,7 +39,7 @@ proc httpdAccept {newsock ipaddr port} { fconfigure $newsock -blocking 0 -translation {auto crlf} httpd_log $newsock Connect $ipaddr $port set data(ipaddr) $ipaddr - fileevent $newsock readable [list httpdRead $newsock] + after 50 [list fileevent $newsock readable [list httpdRead $newsock]] } # read data from a client request -- cgit v0.12 From 596b5e9c70fd7bbef2a6d801c647bb939482961a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 3 Jun 2013 14:19:43 +0000 Subject: last-moment fix for FreeBSD from Pietro Cerutti --- unix/configure | 4 ++-- unix/tcl.m4 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/configure b/unix/configure index ec5298c..36d7b8d 100755 --- a/unix/configure +++ b/unix/configure @@ -3425,14 +3425,14 @@ echo "$ac_t""$tcl_cv_ld_elf" 1>&6 # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname \$@" + TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="" if test $doRpath = yes ; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi if test "${TCL_THREADS}" = "1" ; then # The -pthread needs to go in the LDFLAGS, not LIBS diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 85b8f82..45d19ae 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1564,14 +1564,14 @@ dnl AC_CHECK_TOOL(AR, ar) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname \$[@]" + TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="" if test $doRpath = yes ; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi if test "${TCL_THREADS}" = "1" ; then # The -pthread needs to go in the LDFLAGS, not LIBS -- cgit v0.12 From 63a81f0f749c1cc9965874146ba78f865ad5393a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 3 Jun 2013 14:57:48 +0000 Subject: Next stage of fixing the break/continue generation. --- generic/tclCompCmds.c | 76 +++++++++++++++++++++++++++++---------------------- generic/tclCompile.c | 3 ++ generic/tclCompile.h | 4 ++- generic/tclExecute.c | 11 ++++++++ tests/for.test | 4 +-- 5 files changed, 63 insertions(+), 35 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3046841..3d6abcf 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -493,36 +493,42 @@ TclCompileBreakCmd( rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr); if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - int toPop = envPtr->currStackDepth - auxPtr->stackDepth; + int toPop; + + /* + * Ditch the extra elements from the auxiliary stack. + */ + + toPop = envPtr->expandCount - auxPtr->expandTarget; + while (toPop > 0) { + TclEmitOpcode(INST_EXPAND_DROP, envPtr); + toPop--; + } /* * Pop off the extra stack frames. */ + toPop = envPtr->currStackDepth - auxPtr->stackDepth; while (toPop > 0) { TclEmitOpcode(INST_POP, envPtr); TclAdjustStackDepth(1, envPtr); toPop--; } - if (envPtr->expandCount == auxPtr->expandTarget) { - /* - * Found the target! Also, no built-up expansion stack. No need - * for a nasty INST_BREAK here. - */ - - TclAddLoopBreakFixup(envPtr, auxPtr); - goto done; - } - } + /* + * Found the target! No need for a nasty INST_BREAK here. + */ - /* - * Emit a break instruction. - */ + TclAddLoopBreakFixup(envPtr, auxPtr); + } else { + /* + * Emit a break instruction. + */ - TclEmitOpcode(INST_BREAK, envPtr); + TclEmitOpcode(INST_BREAK, envPtr); + } - done: /* * Instructions that raise exceptions don't really have to follow the * usual stack management rules, but the cleanup code does. @@ -840,36 +846,42 @@ TclCompileContinueCmd( rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr); if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - int toPop = envPtr->currStackDepth - auxPtr->stackDepth; + int toPop; + + /* + * Ditch the extra elements from the auxiliary stack. + */ + + toPop = envPtr->expandCount - auxPtr->expandTarget; + while (toPop > 0) { + TclEmitOpcode(INST_EXPAND_DROP, envPtr); + toPop--; + } /* * Pop off the extra stack frames. */ + toPop = envPtr->currStackDepth - auxPtr->stackDepth; while (toPop > 0) { TclEmitOpcode(INST_POP, envPtr); TclAdjustStackDepth(1, envPtr); toPop--; } - if (envPtr->expandCount == auxPtr->expandTarget) { - /* - * Found the target! Also, no built-up expansion stack. No need - * for a nasty INST_CONTINUE here. - */ - - TclAddLoopContinueFixup(envPtr, auxPtr); - goto done; - } - } + /* + * Found the target! No need for a nasty INST_CONTINUE here. + */ - /* - * Emit a continue instruction. - */ + TclAddLoopContinueFixup(envPtr, auxPtr); + } else { + /* + * Emit a continue instruction. + */ - TclEmitOpcode(INST_CONTINUE, envPtr); + TclEmitOpcode(INST_CONTINUE, envPtr); + } - done: /* * Instructions that raise exceptions don't really have to follow the * usual stack management rules, but the cleanup code does. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f2e9329..f8dd504 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -540,6 +540,9 @@ InstructionDesc const tclInstructionTable[] = { * list and pushes that resulting list onto the stack. * Stack: ... list1 list2 => ... [lconcat list1 list2] */ + {"expandDrop", 1, 0, 0, {OPERAND_NONE}}, + /* Drops an element from the auxiliary stack. */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 957c724..75de025 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -772,8 +772,10 @@ typedef struct ByteCode { #define INST_LIST_CONCAT 164 +#define INST_EXPAND_DROP 165 + /* The last opcode */ -#define LAST_INST_OPCODE 164 +#define LAST_INST_OPCODE 165 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7c645e7..559df0b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2718,6 +2718,17 @@ TEBCresume( PUSH_TAUX_OBJ(objPtr); NEXT_INST_F(1, 0, 0); + case INST_EXPAND_DROP: + /* + * Drops an element of the auxObjList. Does not do any clean up of the + * actual stack. + * + * TODO: POP MAIN STACK BACK TO MARKER + */ + + POP_TAUX_OBJ(); + NEXT_INST_F(1, 0, 0); + case INST_EXPAND_STKTOP: { int i; ptrdiff_t moved; diff --git a/tests/for.test b/tests/for.test index 3f4d2b7..cfba1fe 100644 --- a/tests/for.test +++ b/tests/for.test @@ -854,7 +854,7 @@ test for-7.2 {Bug 3614226: ensure that continue cleans up the stack} memory { expr {$end - $tmp} }} } 0 -test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} {memory knownBug} { +test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} memory { apply {{} { # Can't use [memtest]; must be careful when we change stack frames set end [meminfo] @@ -868,7 +868,7 @@ test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} {mem expr {$end - $tmp} }} } 0 -test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} {memory knownBug} { +test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} memory { apply {{} { # Can't use [memtest]; must be careful when we change stack frames set end [meminfo] -- cgit v0.12 From 312d727024ac9e43d8989d411361cb1d0b50b9b5 Mon Sep 17 00:00:00 2001 From: mig Date: Mon, 3 Jun 2013 16:10:30 +0000 Subject: fix for perf bug detected by Kieran (https://groups.google.com/forum/?fromgroups#!topic/comp.lang.tcl/vfpI3bc-DkQ) --- ChangeLog | 8 ++++++++ generic/tclExecute.c | 11 ++++++----- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index 0661925..9d5e542 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2013-06-03 Miguel Sofer + + * generic/tclExecute.c: fix for perf bug detected by Kieran + (https://groups.google.com/forum/?fromgroups#!topic/comp.lang.tcl/vfpI3bc-DkQ), + diagnosed by dgp to be a close relative of [Bug 781585], which was + fixed by commit [f46fb50cb3]. This bug was introduced by myself in + commit [cbfe055d8c]. + 2013-05-28 Harald Oehlmann * library/msgcat/msgcat.tcl: [Bug 3036566]: Also get locale from diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0de8e3c..8fb8e63 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2424,11 +2424,6 @@ TclExecuteByteCode( if (result == TCL_OK) { Tcl_Obj *objPtr; -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), objc, 0); - } -#endif /* * Push the call's object result and continue execution with * the next instruction. @@ -2455,6 +2450,12 @@ TclExecuteByteCode( TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; +#ifndef TCL_COMPILE_DEBUG + if (*(pc+pcAdjustment) == INST_POP) { + TclDecrRefCount(objResultPtr); + NEXT_INST_V((pcAdjustment+1), objc, 0); + } +#endif NEXT_INST_V(pcAdjustment, objc, -1); } else { cleanup = objc; -- cgit v0.12 From 6f640f9e5701a60ac0fbde981742fd3a80f59d18 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Jun 2013 08:33:16 +0000 Subject: Eliminate NO_VIZ macro as current zlib uses HAVE_HIDDEN in stead. One more last-moment fix for FreeBSD by Pietro Cerutti --- ChangeLog | 6 ++++++ unix/configure | 20 ++++++-------------- unix/tcl.m4 | 12 ++---------- unix/tclConfig.h.in | 4 ++-- win/configure | 4 ---- win/configure.in | 1 - 6 files changed, 16 insertions(+), 31 deletions(-) diff --git a/ChangeLog b/ChangeLog index f2a8c44..53bcb80 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2013-06-04 Jan Nijtmans + + * unix/tcl.m4: Eliminate NO_VIZ macro as current + zlib uses HAVE_HIDDEN in stead. One more last-moment + fix for FreeBSD by Pietro Cerutti + 2013-06-03 Miguel Sofer * generic/tclExecute.c: fix for perf bug detected by Kieran diff --git a/unix/configure b/unix/configure index 583cd01..7626343 100755 --- a/unix/configure +++ b/unix/configure @@ -6617,6 +6617,11 @@ cat >>confdefs.h <<\_ACEOF _ACEOF +cat >>confdefs.h <<\_ACEOF +#define HAVE_HIDDEN 1 +_ACEOF + + fi @@ -7827,20 +7832,12 @@ fi fi - case $system in - FreeBSD-3.*) - # FreeBSD-3 doesn't handle version numbers with dots. - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' - TCL_LIB_VERSIONS_OK=nodots - ;; - esac ;; FreeBSD-*) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" + TCL_SHLIB_LD_EXTRAS="-Wl,-soname=\$@" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" @@ -9057,11 +9054,6 @@ cat >>confdefs.h <<\_ACEOF _ACEOF -cat >>confdefs.h <<\_ACEOF -#define NO_VIZ -_ACEOF - - fi diff --git a/unix/tcl.m4 b/unix/tcl.m4 index cc7c936..43e2b78 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1067,6 +1067,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ 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]) ]) ]) @@ -1537,20 +1538,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" ]) - case $system in - FreeBSD-3.*) - # FreeBSD-3 doesn't handle version numbers with dots. - UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' - SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' - TCL_LIB_VERSIONS_OK=nodots - ;; - esac ;; FreeBSD-*) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" - TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" + TCL_SHLIB_LD_EXTRAS="-Wl,-soname=\$[@]" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" @@ -2048,7 +2041,6 @@ dnl # preprocessing tests use only CPPFLAGS. AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ AC_DEFINE(MODULE_SCOPE, [extern], [No Compiler support for module scope symbols]) - AC_DEFINE(NO_VIZ, [], [No visibility attribute]) ]) AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [ diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 839c2ab..23d6026 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -343,8 +343,8 @@ /* Do we have ? */ #undef NO_VALUES_H -/* No visibility attribute */ -#undef NO_VIZ +/* Compiler support for module scope symbols */ +#undef HAVE_HIDDEN /* Do we have wait3() */ #undef NO_WAIT3 diff --git a/win/configure b/win/configure index 0b07e9f..bad344c 100755 --- a/win/configure +++ b/win/configure @@ -4377,10 +4377,6 @@ else ZLIB_OBJS=\${ZLIB_OBJS} - cat >>confdefs.h <<_ACEOF -#define NO_VIZ 1 -_ACEOF - fi diff --git a/win/configure.in b/win/configure.in index b0c007a..574fce2 100644 --- a/win/configure.in +++ b/win/configure.in @@ -135,7 +135,6 @@ AS_IF([test "$tcl_ok" = "yes"], [ ]) ], [ AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) - AC_DEFINE_UNQUOTED(NO_VIZ, 1) ]) AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) -- cgit v0.12 From e2aebdd0bfef45036c0e1242c55efd86773ecca4 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Jun 2013 07:19:02 +0000 Subject: Stack cleanup works now even in the most evil expansion cases. --- generic/tclAssembly.c | 2 +- generic/tclCompCmds.c | 62 ++++++----------------------- generic/tclCompile.c | 108 ++++++++++++++++++++++++++++++++++++++++++++++++-- generic/tclCompile.h | 7 ++++ generic/tclExecute.c | 11 ++--- tests/for.test | 30 ++++++++++++++ 6 files changed, 160 insertions(+), 60 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index d1af8c6..62641e6 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -20,7 +20,7 @@ *- break and continue - if exception ranges can be sorted out. *- foreach_start4, foreach_step4 *- returnImm, returnStk - *- expandStart, expandStkTop, invokeExpanded + *- expandStart, expandStkTop, invokeExpanded, expandDrop *- dictFirst, dictNext, dictDone *- dictUpdateStart, dictUpdateEnd *- jumpTable testing diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3d6abcf..365e647 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -493,40 +493,21 @@ TclCompileBreakCmd( rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr); if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - int toPop; - - /* - * Ditch the extra elements from the auxiliary stack. - */ - - toPop = envPtr->expandCount - auxPtr->expandTarget; - while (toPop > 0) { - TclEmitOpcode(INST_EXPAND_DROP, envPtr); - toPop--; - } - - /* - * Pop off the extra stack frames. - */ - - toPop = envPtr->currStackDepth - auxPtr->stackDepth; - while (toPop > 0) { - TclEmitOpcode(INST_POP, envPtr); - TclAdjustStackDepth(1, envPtr); - toPop--; - } - /* * Found the target! No need for a nasty INST_BREAK here. */ + TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopBreakFixup(envPtr, auxPtr); } else { /* - * Emit a break instruction. + * Emit a real break. */ - TclEmitOpcode(INST_BREAK, envPtr); + PushStringLiteral(envPtr, ""); + TclEmitOpcode(INST_DUP, envPtr); + TclEmitInstInt4(INST_RETURN_IMM, TCL_BREAK, envPtr); + TclEmitInt4(0, envPtr); } /* @@ -846,40 +827,21 @@ TclCompileContinueCmd( rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr); if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - int toPop; - - /* - * Ditch the extra elements from the auxiliary stack. - */ - - toPop = envPtr->expandCount - auxPtr->expandTarget; - while (toPop > 0) { - TclEmitOpcode(INST_EXPAND_DROP, envPtr); - toPop--; - } - - /* - * Pop off the extra stack frames. - */ - - toPop = envPtr->currStackDepth - auxPtr->stackDepth; - while (toPop > 0) { - TclEmitOpcode(INST_POP, envPtr); - TclAdjustStackDepth(1, envPtr); - toPop--; - } - /* * Found the target! No need for a nasty INST_CONTINUE here. */ + TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopContinueFixup(envPtr, auxPtr); } else { /* - * Emit a continue instruction. + * Emit a real continue. */ - TclEmitOpcode(INST_CONTINUE, envPtr); + PushStringLiteral(envPtr, ""); + TclEmitOpcode(INST_DUP, envPtr); + TclEmitInstInt4(INST_RETURN_IMM, TCL_CONTINUE, envPtr); + TclEmitInt4(0, envPtr); } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f8dd504..69517bc 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -541,7 +541,8 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... list1 list2 => ... [lconcat list1 list2] */ {"expandDrop", 1, 0, 0, {OPERAND_NONE}}, - /* Drops an element from the auxiliary stack. */ + /* Drops an element from the auxiliary stack, popping stack elements + * until the matching stack depth is reached. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -574,6 +575,7 @@ static void RecordByteCodeStats(ByteCode *codePtr); static void RegisterAuxDataType(const AuxDataType *typePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void StartExpanding(CompileEnv *envPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void PrintSourceToObj(Tcl_Obj *appendObj, @@ -2063,8 +2065,7 @@ TclCompileScript( */ if (expand) { - TclEmitOpcode(INST_EXPAND_START, envPtr); - envPtr->expandCount++; + StartExpanding(envPtr); } /* @@ -3469,6 +3470,7 @@ TclCreateExceptRange( auxPtr->supportsContinue = 1; auxPtr->stackDepth = envPtr->currStackDepth; auxPtr->expandTarget = envPtr->expandCount; + auxPtr->expandTargetDepth = -1; auxPtr->numBreakTargets = 0; auxPtr->breakTargets = NULL; auxPtr->allocBreakTargets = 0; @@ -3589,6 +3591,103 @@ TclAddLoopContinueFixup( /* * --------------------------------------------------------------------- * + * TclCleanupStackForBreakContinue -- + * + * Ditch the extra elements from the auxiliary stack and the main + * stack. How to do this exactly depends on whether there are any + * elements on the auxiliary stack to pop. + * + * --------------------------------------------------------------------- + */ + +void +TclCleanupStackForBreakContinue( + CompileEnv *envPtr, + ExceptionAux *auxPtr) +{ + int toPop = envPtr->expandCount - auxPtr->expandTarget; + + if (toPop > 0) { + while (toPop > 0) { + TclEmitOpcode(INST_EXPAND_DROP, envPtr); + toPop--; + } + toPop = auxPtr->expandTargetDepth - auxPtr->stackDepth; + while (toPop > 0) { + TclEmitOpcode(INST_POP, envPtr); + TclAdjustStackDepth(1, envPtr); + toPop--; + } + } else { + toPop = envPtr->currStackDepth - auxPtr->stackDepth; + while (toPop > 0) { + TclEmitOpcode(INST_POP, envPtr); + TclAdjustStackDepth(1, envPtr); + toPop--; + } + } +} + +/* + * --------------------------------------------------------------------- + * + * StartExpanding -- + * + * Pushes an INST_EXPAND_START and does some additional housekeeping so + * that the [break] and [continue] compilers can use an exception-free + * issue to discard it. + * + * --------------------------------------------------------------------- + */ + +static void +StartExpanding( + CompileEnv *envPtr) +{ + int i; + + TclEmitOpcode(INST_EXPAND_START, envPtr); + + /* + * Update inner exception ranges with information about the environment + * where this expansion started. + */ + + for (i=0 ; iexceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i]; + + /* + * Ignore loops unless they're still being built. + */ + + if (rangePtr->codeOffset > CurrentOffset(envPtr)) { + continue; + } + if (rangePtr->numCodeBytes != -1) { + continue; + } + + /* + * Adequate condition: further out loops and further in exceptions + * don't actually need this information. + */ + + if (auxPtr->expandTarget == envPtr->expandCount) { + auxPtr->expandTargetDepth = envPtr->currStackDepth; + } + } + + /* + * There's now one more expansion being processed on the auxiliary stack. + */ + + envPtr->expandCount++; +} + +/* + * --------------------------------------------------------------------- + * * TclFinalizeLoopExceptionRange -- * * Finalizes a loop exception range, binding the registered [break] and @@ -3629,7 +3728,8 @@ TclFinalizeLoopExceptionRange( int j; /* - * WTF? Can't bind, so revert to an INST_CONTINUE. + * WTF? Can't bind, so revert to an INST_CONTINUE. Not enough + * space to do anything else. */ *site = INST_CONTINUE; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 75de025..15b5477 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -120,6 +120,11 @@ typedef struct ExceptionAux { * we can't currently discard them except by * doing INST_INVOKE_EXPANDED; this is a known * problem. */ + int expandTargetDepth; /* The stack depth expected at the outermost + * expansion within the loop. Not meaningful + * if there have are no open expansions + * between the looping level and the point of + * jump issue. */ int numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ @@ -987,6 +992,8 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, */ MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); +MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, + ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 559df0b..fc50a74 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2720,14 +2720,15 @@ TEBCresume( case INST_EXPAND_DROP: /* - * Drops an element of the auxObjList. Does not do any clean up of the - * actual stack. - * - * TODO: POP MAIN STACK BACK TO MARKER + * Drops an element of the auxObjList, popping stack elements to + * restore the stack to the state before the point where the aux + * element was created. */ + CLANG_ASSERT(auxObjList); + objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; POP_TAUX_OBJ(); - NEXT_INST_F(1, 0, 0); + NEXT_INST_V(1, objc, 0); case INST_EXPAND_STKTOP: { int i; diff --git a/tests/for.test b/tests/for.test index cfba1fe..c5803ee 100644 --- a/tests/for.test +++ b/tests/for.test @@ -882,6 +882,36 @@ test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} m expr {$end - $tmp} }} } 0 +test for-7.5 {Bug 3614226: ensure that break cleans up the expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.6 {Bug 3614226: ensure that continue cleans up the expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 4d139bcdd3359f4e4d35db3d5fce67c6b528532c Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Jun 2013 07:51:06 +0000 Subject: Even better tests --- tests/for.test | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/tests/for.test b/tests/for.test index c5803ee..8936682 100644 --- a/tests/for.test +++ b/tests/for.test @@ -882,7 +882,7 @@ test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} m expr {$end - $tmp} }} } 0 -test for-7.5 {Bug 3614226: ensure that break cleans up the expansion stack} memory { +test for-7.5 {Bug 3614226: ensure that break cleans up the combination of main and expansion stack} memory { apply {{} { set l [lrepeat 50 p q r] # Can't use [memtest]; must be careful when we change stack frames @@ -897,7 +897,7 @@ test for-7.5 {Bug 3614226: ensure that break cleans up the expansion stack} memo expr {$end - $tmp} }} } 0 -test for-7.6 {Bug 3614226: ensure that continue cleans up the expansion stack} memory { +test for-7.6 {Bug 3614226: ensure that continue cleans up the combination of main and expansion stack} memory { apply {{} { set l [lrepeat 50 p q r] # Can't use [memtest]; must be careful when we change stack frames @@ -912,6 +912,36 @@ test for-7.6 {Bug 3614226: ensure that continue cleans up the expansion stack} m expr {$end - $tmp} }} } 0 +test for-7.7 {Bug 3614226: ensure that break only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.8 {Bug 3614226: ensure that continue only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 64edc0ede7a6c7770bc5f152e97aa48674ed6682 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Jun 2013 12:34:21 +0000 Subject: More cleaning up; factor out optimizer to new file. Some weird problems still. --- generic/tclCompCmds.c | 30 +++++---- generic/tclCompile.c | 174 +------------------------------------------------- generic/tclCompile.h | 1 + unix/Makefile.in | 6 +- win/Makefile.in | 1 + win/makefile.bc | 1 + win/makefile.vc | 1 + 7 files changed, 26 insertions(+), 188 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 365e647..8cb5fcd 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -499,6 +499,13 @@ TclCompileBreakCmd( TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopBreakFixup(envPtr, auxPtr); + + /* + * Instructions that raise exceptions don't really have to follow the + * usual stack management rules, but the cleanup code does. + */ + + TclAdjustStackDepth(1, envPtr); } else { /* * Emit a real break. @@ -510,12 +517,6 @@ TclCompileBreakCmd( TclEmitInt4(0, envPtr); } - /* - * Instructions that raise exceptions don't really have to follow the - * usual stack management rules, but the cleanup code does. - */ - - TclAdjustStackDepth(1, envPtr); return TCL_OK; } @@ -833,6 +834,13 @@ TclCompileContinueCmd( TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopContinueFixup(envPtr, auxPtr); + + /* + * Instructions that raise exceptions don't really have to follow the + * usual stack management rules, but the cleanup code does. + */ + + TclAdjustStackDepth(1, envPtr); } else { /* * Emit a real continue. @@ -844,12 +852,6 @@ TclCompileContinueCmd( TclEmitInt4(0, envPtr); } - /* - * Instructions that raise exceptions don't really have to follow the - * usual stack management rules, but the cleanup code does. - */ - - TclAdjustStackDepth(1, envPtr); return TCL_OK; } @@ -2121,10 +2123,10 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - envPtr->currStackDepth++; + //envPtr->currStackDepth++; SetLineInformation(parsePtr->numWords-1); CompileBody(envPtr, tokenPtr, interp); - envPtr->currStackDepth = savedStackDepth; + //envPtr->currStackDepth = savedStackDepth; ExceptionRangeEnds(envPtr, range); /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 69517bc..4a989c7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -568,7 +568,6 @@ static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); static int IsCompactibleCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr); -static void PeepholeOptimize(CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ @@ -760,7 +759,7 @@ TclSetByteCodeFromAny( * instruction generator boundaries. */ - PeepholeOptimize(&compEnv); + TclOptimizeBytecode(&compEnv); /* * Invoke the compilation hook procedure if one exists. @@ -1102,177 +1101,6 @@ IsCompactibleCompileEnv( } /* - * ---------------------------------------------------------------------- - * - * PeepholeOptimize -- - * - * A very simple peephole optimizer for bytecode. - * - * ---------------------------------------------------------------------- - */ - -static void -PeepholeOptimize( - CompileEnv *envPtr) -{ - unsigned char *pc, *prev1 = NULL, *prev2 = NULL, *target; - int size, isNew; - Tcl_HashTable targets; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - - /* - * Find places where we should be careful about replacing instructions - * because they are the targets of various types of jumps. - */ - - Tcl_InitHashTable(&targets, TCL_ONE_WORD_KEYS); - for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { - size = tclInstructionTable[*pc].numBytes; - switch (*pc) { - case INST_JUMP1: - case INST_JUMP_TRUE1: - case INST_JUMP_FALSE1: - target = pc + TclGetInt1AtPtr(pc+1); - goto storeTarget; - case INST_JUMP4: - case INST_JUMP_TRUE4: - case INST_JUMP_FALSE4: - target = pc + TclGetInt4AtPtr(pc+1); - goto storeTarget; - case INST_BEGIN_CATCH4: - target = envPtr->codeStart + envPtr->exceptArrayPtr[ - TclGetUInt4AtPtr(pc+1)].codeOffset; - storeTarget: - (void) Tcl_CreateHashEntry(&targets, (void *) target, &isNew); - break; - case INST_JUMP_TABLE: - hPtr = Tcl_FirstHashEntry( - &JUMPTABLEINFO(envPtr, pc+1)->hashTable, &hSearch); - for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { - target = pc + PTR2INT(Tcl_GetHashValue(hPtr)); - (void) Tcl_CreateHashEntry(&targets, (void *) target, &isNew); - } - break; - case INST_START_CMD: - assert (envPtr->atCmdStart < 2); - } - } - - /* - * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also replace - * PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an operation - * that guarantees the check for arithmeticity). - */ - - (void) Tcl_CreateHashEntry(&targets, (void *) pc, &isNew); - for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { - int blank = 0, i, inst; - - size = tclInstructionTable[*pc].numBytes; - prev2 = prev1; - prev1 = pc; - while (*(pc+size) == INST_NOP) { - if (Tcl_FindHashEntry(&targets, (void *) (pc + size))) { - break; - } - size += tclInstructionTable[INST_NOP].numBytes; - } - if (Tcl_FindHashEntry(&targets, (void *) (pc + size))) { - continue; - } - inst = *(pc + size); - switch (*pc) { - case INST_PUSH1: - if (inst == INST_POP) { - blank = size + tclInstructionTable[inst].numBytes; - } else if (inst == INST_CONCAT1 - && TclGetUInt1AtPtr(pc + size + 1) == 2) { - Tcl_Obj *litPtr = TclFetchLiteral(envPtr, - TclGetUInt1AtPtr(pc + 1)); - int numBytes; - - (void) Tcl_GetStringFromObj(litPtr, &numBytes); - if (numBytes == 0) { - blank = size + tclInstructionTable[inst].numBytes; - } - } - break; - case INST_PUSH4: - if (inst == INST_POP) { - blank = size + 1; - } else if (inst == INST_CONCAT1 - && TclGetUInt1AtPtr(pc + size + 1) == 2) { - Tcl_Obj *litPtr = TclFetchLiteral(envPtr, - TclGetUInt4AtPtr(pc + 1)); - int numBytes; - - (void) Tcl_GetStringFromObj(litPtr, &numBytes); - if (numBytes == 0) { - blank = size + tclInstructionTable[inst].numBytes; - } - } - break; - case INST_TRY_CVT_TO_NUMERIC: - switch (inst) { - case INST_JUMP_TRUE1: - case INST_JUMP_TRUE4: - case INST_JUMP_FALSE1: - case INST_JUMP_FALSE4: - case INST_INCR_SCALAR1: - case INST_INCR_ARRAY1: - case INST_INCR_ARRAY_STK: - case INST_INCR_SCALAR_STK: - case INST_INCR_STK: - case INST_LOR: - case INST_LAND: - case INST_EQ: - case INST_NEQ: - case INST_LT: - case INST_LE: - case INST_GT: - case INST_GE: - case INST_MOD: - case INST_LSHIFT: - case INST_RSHIFT: - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - case INST_EXPON: - case INST_ADD: - case INST_SUB: - case INST_DIV: - case INST_MULT: - case INST_LNOT: - case INST_BITNOT: - case INST_UMINUS: - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: - blank = size; - break; - } - break; - } - if (blank > 0) { - for (i=0 ; icodeNext--; - } - Tcl_DeleteHashTable(&targets); -} - -/* *---------------------------------------------------------------------- * * Tcl_SubstObj -- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 15b5477..fdb281b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1060,6 +1060,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); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr); diff --git a/unix/Makefile.in b/unix/Makefile.in index 9bf8b43..3e4a6f6 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -301,7 +301,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \ tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ - tclObj.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ + tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ tclPreserve.o tclProc.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ @@ -429,6 +429,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ $(GENERIC_DIR)/tclObj.c \ + $(GENERIC_DIR)/tclOptimize.c \ $(GENERIC_DIR)/tclParse.c \ $(GENERIC_DIR)/tclPathObj.c \ $(GENERIC_DIR)/tclPipe.c \ @@ -1165,6 +1166,9 @@ tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR) tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c +tclOptimize.o: $(GENERIC_DIR)/tclOptimize.c $(COMPILEHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOptimize.c + tclLoad.o: $(GENERIC_DIR)/tclLoad.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c diff --git a/win/Makefile.in b/win/Makefile.in index 047b0b5..18993fe 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -267,6 +267,7 @@ GENERIC_OBJS = \ tclOOMethod.$(OBJEXT) \ tclOOStubInit.$(OBJEXT) \ tclObj.$(OBJEXT) \ + tclOptimize.$(OBJEXT) \ tclPanic.$(OBJEXT) \ tclParse.$(OBJEXT) \ tclPathObj.$(OBJEXT) \ diff --git a/win/makefile.bc b/win/makefile.bc index d148513..0b17cea 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -239,6 +239,7 @@ TCLOBJS = \ $(TMPDIR)\tclOOMethod.obj \ $(TMPDIR)\tclOOStubInit.obj \ $(TMPDIR)\tclObj.obj \ + $(TMPDIR)\tclOptimize.obj \ $(TMPDIR)\tclPanic.obj \ $(TMPDIR)\tclParse.obj \ $(TMPDIR)\tclPipe.obj \ diff --git a/win/makefile.vc b/win/makefile.vc index 95d3a9d..cddb253 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -316,6 +316,7 @@ COREOBJS = \ $(TMP_DIR)\tclOOMethod.obj \ $(TMP_DIR)\tclOOStubInit.obj \ $(TMP_DIR)\tclObj.obj \ + $(TMP_DIR)\tclOptimize.obj \ $(TMP_DIR)\tclPanic.obj \ $(TMP_DIR)\tclParse.obj \ $(TMP_DIR)\tclPathObj.obj \ -- cgit v0.12 From e8976518be1b4f26d965c08e0229d31ed7bcb101 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 5 Jun 2013 14:50:39 +0000 Subject: Stack Depth fixups. --- generic/tclCompCmds.c | 14 ++------------ generic/tclExecute.c | 2 ++ 2 files changed, 4 insertions(+), 12 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 365e647..10a789e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -499,6 +499,7 @@ TclCompileBreakCmd( TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopBreakFixup(envPtr, auxPtr); + TclAdjustStackDepth(1, envPtr); } else { /* * Emit a real break. @@ -510,12 +511,6 @@ TclCompileBreakCmd( TclEmitInt4(0, envPtr); } - /* - * Instructions that raise exceptions don't really have to follow the - * usual stack management rules, but the cleanup code does. - */ - - TclAdjustStackDepth(1, envPtr); return TCL_OK; } @@ -833,6 +828,7 @@ TclCompileContinueCmd( TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopContinueFixup(envPtr, auxPtr); + TclAdjustStackDepth(1, envPtr); } else { /* * Emit a real continue. @@ -844,12 +840,6 @@ TclCompileContinueCmd( TclEmitInt4(0, envPtr); } - /* - * Instructions that raise exceptions don't really have to follow the - * usual stack management rules, but the cleanup code does. - */ - - TclAdjustStackDepth(1, envPtr); return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 98ce51e..6ee3cae 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2728,6 +2728,8 @@ TEBCresume( CLANG_ASSERT(auxObjList); objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; POP_TAUX_OBJ(); + /* Ugly abuse! */ + starting = 1; NEXT_INST_V(1, objc, 0); case INST_EXPAND_STKTOP: { -- cgit v0.12 From ad80ea28de240aaa62b0140e919648ac3081d54f Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 5 Jun 2013 15:07:40 +0000 Subject: Repair TCL_COMPILE_DEBUG guards --- generic/tclExecute.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6ee3cae..443fb85 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -257,7 +257,7 @@ VarHashCreateVar( /* Verify the stack depth, only when no expansion is in progress */ -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG #define CHECK_STACK() \ do { \ ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \ @@ -2630,7 +2630,7 @@ TEBCresume( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG +#ifndef TCL_COMPILE_DEBUG if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { TclFreeIntRep(objResultPtr); objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); @@ -2666,7 +2666,7 @@ TEBCresume( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG +#ifndef TCL_COMPILE_DEBUG if (!Tcl_IsShared(objResultPtr)) { bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, length + appendLen); @@ -2728,8 +2728,10 @@ TEBCresume( CLANG_ASSERT(auxObjList); objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; POP_TAUX_OBJ(); +#ifdef TCL_COMPILE_DEBUG /* Ugly abuse! */ starting = 1; +#endif NEXT_INST_V(1, objc, 0); case INST_EXPAND_STKTOP: { @@ -6838,7 +6840,7 @@ TEBCresume( */ processExceptionReturn: -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG switch (*pc) { case INST_INVOKE_STK1: opnd = TclGetUInt1AtPtr(pc+1); @@ -6895,7 +6897,7 @@ TEBCresume( rangePtr->codeOffset, rangePtr->continueOffset)); NEXT_INST_F(0, 0, 0); } -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG if (traceInstructions) { objPtr = Tcl_GetObjResult(interp); if ((result != TCL_ERROR) && (result != TCL_RETURN)) { -- cgit v0.12 From 24d2ee6791fc464e86c2aecbd60376628796af06 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Jun 2013 20:55:29 +0000 Subject: Corrected wrong information about instruction width that was causing an optimizer crash. --- generic/tclCompile.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 4a989c7..572f660 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -431,7 +431,7 @@ InstructionDesc const tclInstructionTable[] = { /* Map variable contents back into a dictionary in a variable. Part of * [dict with]. * Stack: ... dictVarName path keyList => ... */ - {"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}}, + {"dictRecombineImm", 5, -2, 1, {OPERAND_LVT4}}, /* Map variable contents back into a dictionary in the local variable * indicated by the LVT index. Part of [dict with]. * Stack: ... path keyList => ... */ -- cgit v0.12 From 38cbf3feb975cb1a1a9bffc69cf773f4f2d2c11c Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Jun 2013 21:05:41 +0000 Subject: Added the optimizer... --- generic/tclOptimize.c | 287 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 287 insertions(+) create mode 100644 generic/tclOptimize.c diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c new file mode 100644 index 0000000..18dc208 --- /dev/null +++ b/generic/tclOptimize.c @@ -0,0 +1,287 @@ +/* + * tclOptimize.c -- + * + * This file contains the bytecode optimizer. + * + * Copyright (c) 2013 by Donal Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include + +#define DefineTargetAddress(tablePtr, address) \ + ((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew)) +#define IsTargetAddress(tablePtr, address) \ + (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL) + +static void +LocateTargetAddresses( + CompileEnv *envPtr, + Tcl_HashTable *tablePtr) +{ + unsigned char *pc, *target; + int size, isNew, i; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS); + + /* + * The starts of commands represent target addresses. + */ + + for (i=0 ; inumCommands ; i++) { + DefineTargetAddress(tablePtr, + envPtr->codeStart + envPtr->cmdMapPtr[i].codeOffset); + } + + /* + * Find places where we should be careful about replacing instructions + * because they are the targets of various types of jumps. + */ + + for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { + size = tclInstructionTable[*pc].numBytes; + switch (*pc) { + case INST_JUMP1: + case INST_JUMP_TRUE1: + case INST_JUMP_FALSE1: + target = pc + TclGetInt1AtPtr(pc+1); + goto storeTarget; + case INST_JUMP4: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + target = pc + TclGetInt4AtPtr(pc+1); + goto storeTarget; + case INST_BEGIN_CATCH4: + target = envPtr->codeStart + envPtr->exceptArrayPtr[ + TclGetUInt4AtPtr(pc+1)].codeOffset; + storeTarget: + DefineTargetAddress(tablePtr, target); + break; + case INST_JUMP_TABLE: + hPtr = Tcl_FirstHashEntry( + &JUMPTABLEINFO(envPtr, pc+1)->hashTable, &hSearch); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { + target = pc + PTR2INT(Tcl_GetHashValue(hPtr)); + DefineTargetAddress(tablePtr, target); + } + break; + case INST_RETURN_CODE_BRANCH: + for (i=TCL_ERROR ; iatCmdStart < 2); + } + } + + /* + * Add a marker *after* the last bytecode instruction. WARNING: points to + * one past the end! + */ + + DefineTargetAddress(tablePtr, pc); + + /* + * Enter in the targets of exception ranges. + */ + + for (i=0 ; iexceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + + if (rangePtr->type == CATCH_EXCEPTION_RANGE) { + target = envPtr->codeStart + rangePtr->catchOffset; + DefineTargetAddress(tablePtr, target); + } else { + target = envPtr->codeStart + rangePtr->breakOffset; + DefineTargetAddress(tablePtr, target); + if (rangePtr->continueOffset >= 0) { + target = envPtr->codeStart + rangePtr->continueOffset; + DefineTargetAddress(tablePtr, target); + } + } + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOptimizeBytecode -- + * + * A very simple peephole optimizer for bytecode. + * + * ---------------------------------------------------------------------- + */ + +void +TclOptimizeBytecode( + CompileEnv *envPtr) +{ + unsigned char *pc; + int size; + Tcl_HashTable targets; + + /* + * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also replace + * PUSH empty/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. + */ + + LocateTargetAddresses(envPtr, &targets); + for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { + int blank = 0, i, inst; + + size = tclInstructionTable[*pc].numBytes; + while (*(pc+size) == INST_NOP) { + if (IsTargetAddress(&targets, pc + size)) { + break; + } + size += tclInstructionTable[INST_NOP].numBytes; + } + if (IsTargetAddress(&targets, pc + size)) { + continue; + } + inst = *(pc + size); + switch (*pc) { + case INST_PUSH1: + if (inst == INST_POP) { + blank = size + tclInstructionTable[inst].numBytes; + } else if (inst == INST_CONCAT1 + && TclGetUInt1AtPtr(pc + size + 1) == 2) { + Tcl_Obj *litPtr = TclFetchLiteral(envPtr, + TclGetUInt1AtPtr(pc + 1)); + int numBytes; + + (void) Tcl_GetStringFromObj(litPtr, &numBytes); + if (numBytes == 0) { + blank = size + tclInstructionTable[inst].numBytes; + } + } + break; + case INST_PUSH4: + if (inst == INST_POP) { + blank = size + 1; + } else if (inst == INST_CONCAT1 + && TclGetUInt1AtPtr(pc + size + 1) == 2) { + Tcl_Obj *litPtr = TclFetchLiteral(envPtr, + TclGetUInt4AtPtr(pc + 1)); + int numBytes; + + (void) Tcl_GetStringFromObj(litPtr, &numBytes); + if (numBytes == 0) { + blank = size + tclInstructionTable[inst].numBytes; + } + } + break; + case INST_LNOT: + switch (inst) { + case INST_JUMP_TRUE1: + blank = size; + *(pc + size) = INST_JUMP_FALSE1; + break; + case INST_JUMP_FALSE1: + blank = size; + *(pc + size) = INST_JUMP_TRUE1; + break; + case INST_JUMP_TRUE4: + blank = size; + *(pc + size) = INST_JUMP_FALSE4; + break; + case INST_JUMP_FALSE4: + blank = size; + *(pc + size) = INST_JUMP_TRUE4; + break; + } + break; + case INST_TRY_CVT_TO_NUMERIC: + switch (inst) { + case INST_JUMP_TRUE1: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE1: + case INST_JUMP_FALSE4: + case INST_INCR_SCALAR1: + case INST_INCR_ARRAY1: + case INST_INCR_ARRAY_STK: + case INST_INCR_SCALAR_STK: + case INST_INCR_STK: + case INST_LOR: + case INST_LAND: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_LE: + case INST_GT: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + blank = size; + break; + } + break; + } + if (blank > 0) { + for (i=0 ; icodeStart ; pc < envPtr->codeNext-1 ; pc += size) { + int clear = 0; + + size = tclInstructionTable[*pc].numBytes; + if (*pc != INST_DONE) { + continue; + } + assert (size == 1); + while (!IsTargetAddress(&targets, pc + 1 + clear)) { + clear += tclInstructionTable[*(pc + 1 + clear)].numBytes; + } + if (pc + 1 + clear == envPtr->codeNext) { + envPtr->codeNext -= clear; + } else { + while (clear --> 0) { + *(pc + 1 + clear) = INST_NOP; + } + } + } + + Tcl_DeleteHashTable(&targets); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ -- cgit v0.12 From 7759a4f4afa6448af2ba2495a40816b70683748d Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Jun 2013 23:05:58 +0000 Subject: Added optimizing of jump-to-nop and jump-to-jump cases. Ta to AK for suggesting. --- generic/tclOptimize.c | 209 ++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 152 insertions(+), 57 deletions(-) diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 18dc208..3e0d351 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -13,18 +13,45 @@ #include "tclCompile.h" #include +/* + * Forward declarations. + */ + +static void LocateTargetAddresses(CompileEnv *envPtr, + Tcl_HashTable *tablePtr); + +/* + * Helper macros. + */ + #define DefineTargetAddress(tablePtr, address) \ ((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew)) #define IsTargetAddress(tablePtr, address) \ (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL) +#define AddrLength(address) \ + (tclInstructionTable[*(unsigned char *)(address)].numBytes) +#define InstLength(instruction) \ + (tclInstructionTable[(unsigned char)(instruction)].numBytes) +/* + * ---------------------------------------------------------------------- + * + * LocateTargetAddresses -- + * + * Populate a hash table with places that we need to be careful around + * because they're the targets of various kinds of jumps and other + * non-local behavior. + * + * ---------------------------------------------------------------------- + */ + static void LocateTargetAddresses( CompileEnv *envPtr, Tcl_HashTable *tablePtr) { - unsigned char *pc, *target; - int size, isNew, i; + unsigned char *currentInstPtr, *targetInstPtr; + int isNew, i; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; @@ -44,36 +71,39 @@ LocateTargetAddresses( * because they are the targets of various types of jumps. */ - for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { - size = tclInstructionTable[*pc].numBytes; - switch (*pc) { + for (currentInstPtr = envPtr->codeStart ; + currentInstPtr < envPtr->codeNext ; + currentInstPtr += AddrLength(currentInstPtr)) { + switch (*currentInstPtr) { case INST_JUMP1: case INST_JUMP_TRUE1: case INST_JUMP_FALSE1: - target = pc + TclGetInt1AtPtr(pc+1); + targetInstPtr = currentInstPtr+TclGetInt1AtPtr(currentInstPtr+1); goto storeTarget; case INST_JUMP4: case INST_JUMP_TRUE4: case INST_JUMP_FALSE4: - target = pc + TclGetInt4AtPtr(pc+1); + targetInstPtr = currentInstPtr+TclGetInt4AtPtr(currentInstPtr+1); goto storeTarget; case INST_BEGIN_CATCH4: - target = envPtr->codeStart + envPtr->exceptArrayPtr[ - TclGetUInt4AtPtr(pc+1)].codeOffset; + targetInstPtr = envPtr->codeStart + envPtr->exceptArrayPtr[ + TclGetUInt4AtPtr(currentInstPtr+1)].codeOffset; storeTarget: - DefineTargetAddress(tablePtr, target); + DefineTargetAddress(tablePtr, targetInstPtr); break; case INST_JUMP_TABLE: hPtr = Tcl_FirstHashEntry( - &JUMPTABLEINFO(envPtr, pc+1)->hashTable, &hSearch); + &JUMPTABLEINFO(envPtr, currentInstPtr+1)->hashTable, + &hSearch); for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { - target = pc + PTR2INT(Tcl_GetHashValue(hPtr)); - DefineTargetAddress(tablePtr, target); + targetInstPtr = currentInstPtr + + PTR2INT(Tcl_GetHashValue(hPtr)); + DefineTargetAddress(tablePtr, targetInstPtr); } break; case INST_RETURN_CODE_BRANCH: for (i=TCL_ERROR ; iexceptArrayPtr[i]; if (rangePtr->type == CATCH_EXCEPTION_RANGE) { - target = envPtr->codeStart + rangePtr->catchOffset; - DefineTargetAddress(tablePtr, target); + targetInstPtr = envPtr->codeStart + rangePtr->catchOffset; + DefineTargetAddress(tablePtr, targetInstPtr); } else { - target = envPtr->codeStart + rangePtr->breakOffset; - DefineTargetAddress(tablePtr, target); + targetInstPtr = envPtr->codeStart + rangePtr->breakOffset; + DefineTargetAddress(tablePtr, targetInstPtr); if (rangePtr->continueOffset >= 0) { - target = envPtr->codeStart + rangePtr->continueOffset; - DefineTargetAddress(tablePtr, target); + targetInstPtr = envPtr->codeStart + rangePtr->continueOffset; + DefineTargetAddress(tablePtr, targetInstPtr); } } } @@ -123,7 +153,7 @@ void TclOptimizeBytecode( CompileEnv *envPtr) { - unsigned char *pc; + unsigned char *currentInstPtr; int size; Tcl_HashTable targets; @@ -135,73 +165,74 @@ TclOptimizeBytecode( */ LocateTargetAddresses(envPtr, &targets); - for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { - int blank = 0, i, inst; + for (currentInstPtr = envPtr->codeStart ; + currentInstPtr < envPtr->codeNext ; currentInstPtr += size) { + int blank = 0, i, nextInst; - size = tclInstructionTable[*pc].numBytes; - while (*(pc+size) == INST_NOP) { - if (IsTargetAddress(&targets, pc + size)) { + size = AddrLength(currentInstPtr); + while (*(currentInstPtr+size) == INST_NOP) { + if (IsTargetAddress(&targets, currentInstPtr + size)) { break; } - size += tclInstructionTable[INST_NOP].numBytes; + size += InstLength(INST_NOP); } - if (IsTargetAddress(&targets, pc + size)) { + if (IsTargetAddress(&targets, currentInstPtr + size)) { continue; } - inst = *(pc + size); - switch (*pc) { + nextInst = *(currentInstPtr + size); + switch (*currentInstPtr) { case INST_PUSH1: - if (inst == INST_POP) { - blank = size + tclInstructionTable[inst].numBytes; - } else if (inst == INST_CONCAT1 - && TclGetUInt1AtPtr(pc + size + 1) == 2) { + if (nextInst == INST_POP) { + blank = size + InstLength(nextInst); + } else if (nextInst == INST_CONCAT1 + && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, - TclGetUInt1AtPtr(pc + 1)); + TclGetUInt1AtPtr(currentInstPtr + 1)); int numBytes; (void) Tcl_GetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { - blank = size + tclInstructionTable[inst].numBytes; + blank = size + InstLength(nextInst); } } break; case INST_PUSH4: - if (inst == INST_POP) { + if (nextInst == INST_POP) { blank = size + 1; - } else if (inst == INST_CONCAT1 - && TclGetUInt1AtPtr(pc + size + 1) == 2) { + } else if (nextInst == INST_CONCAT1 + && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, - TclGetUInt4AtPtr(pc + 1)); + TclGetUInt4AtPtr(currentInstPtr + 1)); int numBytes; (void) Tcl_GetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { - blank = size + tclInstructionTable[inst].numBytes; + blank = size + InstLength(nextInst); } } break; case INST_LNOT: - switch (inst) { + switch (nextInst) { case INST_JUMP_TRUE1: blank = size; - *(pc + size) = INST_JUMP_FALSE1; + *(currentInstPtr + size) = INST_JUMP_FALSE1; break; case INST_JUMP_FALSE1: blank = size; - *(pc + size) = INST_JUMP_TRUE1; + *(currentInstPtr + size) = INST_JUMP_TRUE1; break; case INST_JUMP_TRUE4: blank = size; - *(pc + size) = INST_JUMP_FALSE4; + *(currentInstPtr + size) = INST_JUMP_FALSE4; break; case INST_JUMP_FALSE4: blank = size; - *(pc + size) = INST_JUMP_TRUE4; + *(currentInstPtr + size) = INST_JUMP_TRUE4; break; } break; case INST_TRY_CVT_TO_NUMERIC: - switch (inst) { + switch (nextInst) { case INST_JUMP_TRUE1: case INST_JUMP_TRUE4: case INST_JUMP_FALSE1: @@ -242,7 +273,7 @@ TclOptimizeBytecode( } if (blank > 0) { for (i=0 ; icodeStart ; + currentInstPtr < envPtr->codeNext-1 ; + currentInstPtr += AddrLength(currentInstPtr)) { + int offset, delta; + + switch (*currentInstPtr) { + case INST_JUMP1: + case INST_JUMP_TRUE1: + case INST_JUMP_FALSE1: + offset = TclGetInt1AtPtr(currentInstPtr + 1); + delta = 0; + advanceNext1: + if (offset + delta == 0) { + continue; + } + if (offset + delta < -128 || offset + delta > 127) { + TclStoreInt1AtPtr(offset, currentInstPtr + 1); + continue; + } + offset += delta; + switch (*(currentInstPtr + offset)) { + case INST_NOP: + delta = InstLength(INST_NOP); + goto advanceNext1; + case INST_JUMP1: + delta = TclGetInt1AtPtr(currentInstPtr + offset + 1); + goto advanceNext1; + case INST_JUMP4: + delta = TclGetInt4AtPtr(currentInstPtr + offset + 1); + goto advanceNext1; + default: + TclStoreInt1AtPtr(offset, currentInstPtr + 1); + continue; + } + case INST_JUMP4: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + offset = TclGetInt4AtPtr(currentInstPtr + 1); + advanceNext4: + if (offset == 0) { + continue; + } + switch (*(currentInstPtr + offset)) { + case INST_NOP: + offset += InstLength(INST_NOP); + goto advanceNext4; + case INST_JUMP1: + offset += TclGetInt1AtPtr(currentInstPtr + offset + 1); + goto advanceNext4; + case INST_JUMP4: + offset += TclGetInt4AtPtr(currentInstPtr + offset + 1); + goto advanceNext4; + default: + TclStoreInt4AtPtr(offset, currentInstPtr + 1); + continue; + } + } + } + + /* * Trim unreachable instructions after a DONE. */ LocateTargetAddresses(envPtr, &targets); - for (pc = envPtr->codeStart ; pc < envPtr->codeNext-1 ; pc += size) { + for (currentInstPtr = envPtr->codeStart ; + currentInstPtr < envPtr->codeNext-1 ; + currentInstPtr += AddrLength(currentInstPtr)) { int clear = 0; - size = tclInstructionTable[*pc].numBytes; - if (*pc != INST_DONE) { + if (*currentInstPtr != INST_DONE) { continue; } - assert (size == 1); - while (!IsTargetAddress(&targets, pc + 1 + clear)) { - clear += tclInstructionTable[*(pc + 1 + clear)].numBytes; + + while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) { + clear += AddrLength(currentInstPtr + 1 + clear); } - if (pc + 1 + clear == envPtr->codeNext) { + if (currentInstPtr + 1 + clear == envPtr->codeNext) { envPtr->codeNext -= clear; } else { while (clear --> 0) { - *(pc + 1 + clear) = INST_NOP; + *(currentInstPtr + 1 + clear) = INST_NOP; } } } -- cgit v0.12 From d2874a90b95a1cac70a0c8e84908154356a9a18d Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 6 Jun 2013 06:53:55 +0000 Subject: Split the optimizer up. Remove the dreaded 'goto' from which doesn't need it. --- generic/tclOptimize.c | 208 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 127 insertions(+), 81 deletions(-) diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 3e0d351..7d4226e 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -17,8 +17,11 @@ * Forward declarations. */ +static void AdvanceJumps(CompileEnv *envPtr); +static void ConvertZeroEffectToNOP(CompileEnv *envPtr); static void LocateTargetAddresses(CompileEnv *envPtr, Tcl_HashTable *tablePtr); +static void TrimUnreachable(CompileEnv *envPtr); /* * Helper macros. @@ -142,27 +145,67 @@ LocateTargetAddresses( /* * ---------------------------------------------------------------------- * - * TclOptimizeBytecode -- + * TrimUnreachable -- * - * A very simple peephole optimizer for bytecode. + * Converts code that provably can't be executed into NOPs and reduces + * the overall reported length of the bytecode where that is possible. * * ---------------------------------------------------------------------- */ -void -TclOptimizeBytecode( +static void +TrimUnreachable( CompileEnv *envPtr) { unsigned char *currentInstPtr; - int size; Tcl_HashTable targets; - /* - * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also replace - * PUSH empty/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. - */ + LocateTargetAddresses(envPtr, &targets); + + for (currentInstPtr = envPtr->codeStart ; + currentInstPtr < envPtr->codeNext-1 ; + currentInstPtr += AddrLength(currentInstPtr)) { + int clear = 0; + + if (*currentInstPtr != INST_DONE) { + continue; + } + + while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) { + clear += AddrLength(currentInstPtr + 1 + clear); + } + if (currentInstPtr + 1 + clear == envPtr->codeNext) { + envPtr->codeNext -= clear; + } else { + while (clear --> 0) { + *(currentInstPtr + 1 + clear) = INST_NOP; + } + } + } + + Tcl_DeleteHashTable(&targets); +} + +/* + * ---------------------------------------------------------------------- + * + * ConvertZeroEffectToNOP -- + * + * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also + * replace PUSH empty/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. + * + * ---------------------------------------------------------------------- + */ + +static void +ConvertZeroEffectToNOP( + CompileEnv *envPtr) +{ + unsigned char *currentInstPtr; + int size; + Tcl_HashTable targets; LocateTargetAddresses(envPtr, &targets); for (currentInstPtr = envPtr->codeStart ; @@ -211,6 +254,7 @@ TclOptimizeBytecode( } } break; + case INST_LNOT: switch (nextInst) { case INST_JUMP_TRUE1: @@ -231,6 +275,7 @@ TclOptimizeBytecode( break; } break; + case INST_TRY_CVT_TO_NUMERIC: switch (nextInst) { case INST_JUMP_TRUE1: @@ -271,6 +316,7 @@ TclOptimizeBytecode( } break; } + if (blank > 0) { for (i=0 ; icodeStart ; currentInstPtr < envPtr->codeNext-1 ; @@ -294,82 +355,67 @@ TclOptimizeBytecode( case INST_JUMP_TRUE1: case INST_JUMP_FALSE1: offset = TclGetInt1AtPtr(currentInstPtr + 1); - delta = 0; - advanceNext1: - if (offset + delta == 0) { - continue; - } - if (offset + delta < -128 || offset + delta > 127) { - TclStoreInt1AtPtr(offset, currentInstPtr + 1); - continue; - } - offset += delta; - switch (*(currentInstPtr + offset)) { - case INST_NOP: - delta = InstLength(INST_NOP); - goto advanceNext1; - case INST_JUMP1: - delta = TclGetInt1AtPtr(currentInstPtr + offset + 1); - goto advanceNext1; - case INST_JUMP4: - delta = TclGetInt4AtPtr(currentInstPtr + offset + 1); - goto advanceNext1; - default: - TclStoreInt1AtPtr(offset, currentInstPtr + 1); - continue; + for (delta=0 ; offset+delta != 0 ;) { + if (offset + delta < -128 || offset + delta > 127) { + break; + } + offset += delta; + switch (*(currentInstPtr + offset)) { + case INST_NOP: + delta = InstLength(INST_NOP); + continue; + case INST_JUMP1: + delta = TclGetInt1AtPtr(currentInstPtr + offset + 1); + continue; + case INST_JUMP4: + delta = TclGetInt4AtPtr(currentInstPtr + offset + 1); + continue; + } + break; } + TclStoreInt1AtPtr(offset, currentInstPtr + 1); + continue; + case INST_JUMP4: case INST_JUMP_TRUE4: case INST_JUMP_FALSE4: - offset = TclGetInt4AtPtr(currentInstPtr + 1); - advanceNext4: - if (offset == 0) { - continue; - } - switch (*(currentInstPtr + offset)) { - case INST_NOP: - offset += InstLength(INST_NOP); - goto advanceNext4; - case INST_JUMP1: - offset += TclGetInt1AtPtr(currentInstPtr + offset + 1); - goto advanceNext4; - case INST_JUMP4: - offset += TclGetInt4AtPtr(currentInstPtr + offset + 1); - goto advanceNext4; - default: - TclStoreInt4AtPtr(offset, currentInstPtr + 1); - continue; + for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) { + switch (*(currentInstPtr + offset)) { + case INST_NOP: + offset += InstLength(INST_NOP); + continue; + case INST_JUMP1: + offset += TclGetInt1AtPtr(currentInstPtr + offset + 1); + continue; + case INST_JUMP4: + offset += TclGetInt4AtPtr(currentInstPtr + offset + 1); + continue; + } + break; } - } - } - - /* - * Trim unreachable instructions after a DONE. - */ - - LocateTargetAddresses(envPtr, &targets); - for (currentInstPtr = envPtr->codeStart ; - currentInstPtr < envPtr->codeNext-1 ; - currentInstPtr += AddrLength(currentInstPtr)) { - int clear = 0; - - if (*currentInstPtr != INST_DONE) { + TclStoreInt4AtPtr(offset, currentInstPtr + 1); continue; } - - while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) { - clear += AddrLength(currentInstPtr + 1 + clear); - } - if (currentInstPtr + 1 + clear == envPtr->codeNext) { - envPtr->codeNext -= clear; - } else { - while (clear --> 0) { - *(currentInstPtr + 1 + clear) = INST_NOP; - } - } } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOptimizeBytecode -- + * + * A very simple peephole optimizer for bytecode. + * + * ---------------------------------------------------------------------- + */ - Tcl_DeleteHashTable(&targets); +void +TclOptimizeBytecode( + CompileEnv *envPtr) +{ + ConvertZeroEffectToNOP(envPtr); + AdvanceJumps(envPtr); + TrimUnreachable(envPtr); } /* -- cgit v0.12 From 6f9ac2478c554fbf3fff18e76b690199ade088cb Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 6 Jun 2013 06:56:20 +0000 Subject: Minor grammar fix. --- generic/tclCompile.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index fdb281b..908dceb 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -122,9 +122,9 @@ typedef struct ExceptionAux { * problem. */ int expandTargetDepth; /* The stack depth expected at the outermost * expansion within the loop. Not meaningful - * if there have are no open expansions - * between the looping level and the point of - * jump issue. */ + * if there are no open expansions between the + * looping level and the point of jump + * issue. */ int numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ -- cgit v0.12 From deb30edf39eedf62f9b626a56fa6fa428cb46825 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Jun 2013 14:24:35 +0000 Subject: 3614360 Repair stack demands of optimized compiled [return LITERAL]. --- generic/tclCompCmdsGR.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index d101d82..5e3d456 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2471,6 +2471,7 @@ TclCompileReturnCmd( Tcl_DecrRefCount(returnOpts); TclEmitOpcode(INST_DONE, envPtr); + TclAdjustStackDepth(1, envPtr); return TCL_OK; } } -- cgit v0.12 From 1486f60b5f64b30894635c951cc50d6aeb2cc8a1 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Jun 2013 16:55:08 +0000 Subject: 3614382 Fix stack management of compiled [dict for] by shifting limits of the catch range. --- generic/tclCompCmds.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7324360..92dfcb4 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1496,9 +1496,6 @@ CompileDictEachCmd( */ CompileWord(envPtr, dictTokenPtr, interp, 3); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); /* * Now we catch errors from here on so that we can finalize the search @@ -1509,6 +1506,10 @@ CompileDictEachCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); ExceptionRangeStarts(envPtr, catchRange); + TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); + emptyTargetOffset = CurrentOffset(envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); + /* * Inside the iteration, write the loop variables. */ -- cgit v0.12 From 89472a2027d1ef3616e36b9067d5b2ccca84b3e0 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 6 Jun 2013 21:01:04 +0000 Subject: More efficient instruction sequence for [dict for] with correct exception depth handling. --- generic/tclCompCmds.c | 33 ++++++++++----------------------- tests/dict.test | 18 ++++++++++++++++++ 2 files changed, 28 insertions(+), 23 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 92dfcb4..86e9987 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1560,24 +1560,8 @@ CompileDictEachCmd( TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * Now do the final cleanup for the no-error case (this is where we break - * out of the loop to) by force-terminating the iteration (if not already - * terminated), ditching the exception info and jumping to the last - * instruction for this command. In theory, this could be done using the - * "finally" clause (next generated) but this is faster. - */ - - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, loopRange); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP4, 0, envPtr); + TclEmitInstInt1( INST_JUMP1, 0, envPtr); /* * Error handler "finally" clause, which force-terminates the iteration @@ -1587,9 +1571,9 @@ CompileDictEachCmd( ExceptionRangeTarget(envPtr, catchRange, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); if (collect == TCL_EACH_COLLECT) { TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( collectVar, envPtr); @@ -1606,10 +1590,14 @@ CompileDictEachCmd( jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + emptyTargetOffset); + jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; + TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement, + envPtr->codeStart + endTargetOffset); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, loopRange); + TclEmitOpcode( INST_END_CATCH, envPtr); /* * Final stage of the command (normal case) is that we push an empty @@ -1617,9 +1605,8 @@ CompileDictEachCmd( * last to promote peephole optimization when it's dropped immediately. */ - jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; - TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, - envPtr->codeStart + endTargetOffset); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); diff --git a/tests/dict.test b/tests/dict.test index 72a336c..02c9050 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -668,6 +668,24 @@ test dict-14.20 {dict for stack space compilation: bug 1903325} { concat "c=$y,$args" }} {} 1 2 3 } {c=1,2 3} +test dict-14.21 {compiled dict for and break} { + apply {{} { + dict for {a b} {c d e f} { + lappend result $a,$b + break + } + return $result + }} +} c,d +test dict-14.22 {dict for and exception range depths: Bug 3614382} { + apply {{} { + dict for {a b} {c d} { + dict for {e f} {g h} { + return 5 + } + } + }} +} 5 # There's probably a lot more tests to add here. Really ought to use a # coverage tool for this job... -- cgit v0.12 From 61b945b1318228d66f41c3352fd8134372acd70b Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 7 Jun 2013 12:48:58 +0000 Subject: Simplify stack depth management. --- generic/tclCompCmds.c | 64 ++++++++++++++++++++++++++------------------------- 1 file changed, 33 insertions(+), 31 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 86e9987..2c1198d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1630,7 +1630,6 @@ TclCompileDictUpdateCmd( const char *name; int i, nameChars, dictIndex, numVars, range, infoIndex; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; - int savedStackDepth = envPtr->currStackDepth; DictUpdateInfo *duiPtr; JumpFixup jumpFixup; @@ -1660,16 +1659,16 @@ TclCompileDictUpdateCmd( dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); + goto issueFallback; } name = dictVarTokenPtr[1].start; nameChars = dictVarTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); + goto issueFallback; } dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); if (dictIndex < 0) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); + goto issueFallback; } /* @@ -1680,8 +1679,7 @@ TclCompileDictUpdateCmd( duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); duiPtr->length = numVars; - keyTokenPtrs = TclStackAlloc(interp, - sizeof(Tcl_Token *) * numVars); + keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); for (i=0 ; itype != TCL_TOKEN_SIMPLE_WORD) { - failedUpdateInfoAssembly: - ckfree(duiPtr); - TclStackFree(interp, keyTokenPtrs); - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); + goto failedUpdateInfoAssembly; } bodyTokenPtr = tokenPtr; @@ -1736,16 +1731,14 @@ TclCompileDictUpdateCmd( } TclEmitInstInt4( INST_LIST, numVars, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - envPtr->currStackDepth++; SetLineInformation(parsePtr->numWords - 1); CompileBody(envPtr, bodyTokenPtr, interp); - envPtr->currStackDepth = savedStackDepth; ExceptionRangeEnds(envPtr, range); /* @@ -1756,7 +1749,7 @@ TclCompileDictUpdateCmd( TclEmitOpcode( INST_END_CATCH, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Jump around the exceptional termination code. @@ -1777,7 +1770,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { @@ -1785,8 +1778,17 @@ TclCompileDictUpdateCmd( (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } TclStackFree(interp, keyTokenPtrs); - envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; + + /* + * Clean up after a failure to create the DictUpdateInfo structure. + */ + + failedUpdateInfoAssembly: + ckfree(duiPtr); + TclStackFree(interp, keyTokenPtrs); + issueFallback: + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } int @@ -1875,6 +1877,10 @@ TclCompileDictLappendCmd( return TCL_ERROR; } + /* + * Parse the arguments. + */ + varTokenPtr = TokenAfter(parsePtr->tokenPtr); keyTokenPtr = TokenAfter(varTokenPtr); valueTokenPtr = TokenAfter(keyTokenPtr); @@ -1890,6 +1896,11 @@ TclCompileDictLappendCmd( if (dictVarIndex < 0) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } + + /* + * Issue the implementation. + */ + CompileWord(envPtr, keyTokenPtr, interp, 3); CompileWord(envPtr, valueTokenPtr, interp, 4); TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); @@ -1906,10 +1917,9 @@ TclCompileDictWithCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1; + int i, range, varNameTmp = -1, pathTmp, keysTmp, gotPath, dictVar = -1; int bodyIsEmpty = 1; Tcl_Token *varTokenPtr, *tokenPtr; - int savedStackDepth = envPtr->currStackDepth; JumpFixup jumpFixup; const char *ptr, *end; @@ -1988,7 +1998,6 @@ TclCompileDictWithCmd( TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - PushStringLiteral(envPtr, ""); } else { /* * Case: Direct dict in LVT with empty body. @@ -1999,7 +2008,6 @@ TclCompileDictWithCmd( PushStringLiteral(envPtr, ""); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - PushStringLiteral(envPtr, ""); } } else { if (gotPath) { @@ -2018,7 +2026,6 @@ TclCompileDictWithCmd( TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - PushStringLiteral(envPtr, ""); } else { /* * Case: Direct dict in non-simple var with empty body. @@ -2032,10 +2039,9 @@ TclCompileDictWithCmd( PushStringLiteral(envPtr, ""); TclEmitInstInt4(INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - PushStringLiteral(envPtr, ""); } } - envPtr->currStackDepth = savedStackDepth + 1; + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -2049,8 +2055,6 @@ TclCompileDictWithCmd( if (dictVar == -1) { varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); - } else { - varNameTmp = -1; } if (gotPath) { pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); @@ -2063,7 +2067,7 @@ TclCompileDictWithCmd( * Issue instructions. First, the part to expand the dictionary. */ - if (varNameTmp > -1) { + if (dictVar == -1) { CompileWord(envPtr, varTokenPtr, interp, 0); Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); } @@ -2108,7 +2112,7 @@ TclCompileDictWithCmd( */ TclEmitOpcode( INST_END_CATCH, envPtr); - if (varNameTmp > -1) { + if (dictVar == -1) { Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } if (gotPath) { @@ -2128,11 +2132,12 @@ TclCompileDictWithCmd( * Now fold the results back into the dictionary in the exception case. */ + TclAdjustStackDepth(-1, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); - if (varNameTmp > -1) { + if (dictVar == -1) { Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } if (parsePtr->numWords > 3) { @@ -2152,7 +2157,6 @@ TclCompileDictWithCmd( * Prepare for the start of the next command. */ - envPtr->currStackDepth = savedStackDepth + 1; if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); @@ -2252,7 +2256,6 @@ TclCompileErrorCmd( * However, we only deal with the case where there is just a message. */ Tcl_Token *messageTokenPtr; - int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 2) { @@ -2263,7 +2266,6 @@ TclCompileErrorCmd( PushStringLiteral(envPtr, "-code error -level 0"); CompileWord(envPtr, messageTokenPtr, interp, 1); TclEmitOpcode(INST_RETURN_STK, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } -- cgit v0.12 From 10c2a79550f9ca620b2c90fe2b4d1490980de7a7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 8 Jun 2013 13:17:26 +0000 Subject: Factor out stereotypical ways of getting variable indices. --- generic/tclCompCmds.c | 189 ++++++++++-------------------------------------- generic/tclCompCmdsSZ.c | 20 +++-- generic/tclCompile.h | 14 ++++ 3 files changed, 63 insertions(+), 160 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 2c1198d..25c4bac 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -317,10 +317,10 @@ TclCompileArraySetCmd( * Prepare for the internal foreach. */ - dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + dataVar = AnonymousLocal(envPtr); + iterVar = AnonymousLocal(envPtr); + keyVar = AnonymousLocal(envPtr); + valVar = AnonymousLocal(envPtr); infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; @@ -543,8 +543,7 @@ TclCompileCatchCmd( { JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - const char *name; - int resultIndex, optsIndex, nameChars, range; + int resultIndex, optsIndex, range; int initStackDepth = envPtr->currStackDepth; int savedStackDepth; DefineLineInformation; /* TIP #280 */ @@ -577,17 +576,7 @@ TclCompileCatchCmd( if (parsePtr->numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); /* DGP */ - if (resultNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - name = resultNameTokenPtr[1].start; - nameChars = resultNameTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start, - resultNameTokenPtr[1].size, /*create*/ 1, envPtr); + resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); if (resultIndex < 0) { return TCL_ERROR; } @@ -595,16 +584,7 @@ TclCompileCatchCmd( /* DKF */ if (parsePtr->numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); - if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = optsNameTokenPtr[1].start; - nameChars = optsNameTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start, - optsNameTokenPtr[1].size, /*create*/ 1, envPtr); + optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr); if (optsIndex < 0) { return TCL_ERROR; } @@ -871,11 +851,9 @@ TclCompileDictSetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int numWords, i, dictVarIndex; DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - int dictVarIndex, nameChars; - const char *name; /* * There must be at least one argument after the command. @@ -892,15 +870,7 @@ TclCompileDictSetCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); if (dictVarIndex < 0) { return TCL_ERROR; } @@ -937,8 +907,7 @@ TclCompileDictIncrCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr; - int dictVarIndex, nameChars, incrAmount; - const char *name; + int dictVarIndex, incrAmount; /* * There must be at least two arguments after the command. @@ -984,15 +953,7 @@ TclCompileDictIncrCmd( * discover what the index is. */ - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); if (dictVarIndex < 0) { return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1092,8 +1053,7 @@ TclCompileDictUnsetCmd( { Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ - int i, dictVarIndex, nameChars; - const char *name; + int i, dictVarIndex; /* * There must be at least one argument after the variable name for us to @@ -1111,15 +1071,7 @@ TclCompileDictUnsetCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - name = tokenPtr[1].start; - nameChars = tokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); if (dictVarIndex < 0) { return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1210,7 +1162,7 @@ TclCompileDictCreateCmd( */ nonConstant: - worker = TclFindCompiledLocal(NULL, 0, 1, envPtr); + worker = AnonymousLocal(envPtr); if (worker < 0) { return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1271,11 +1223,11 @@ TclCompileDictMergeCmd( * command when there's an LVT present. */ - workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + workerIndex = AnonymousLocal(envPtr); if (workerIndex < 0) { return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } - infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + infoIndex = AnonymousLocal(envPtr); /* * Get the first dictionary and verify that it is so. @@ -1421,8 +1373,7 @@ CompileDictEachCmd( */ if (collect == TCL_EACH_COLLECT) { - collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, - envPtr); + collectVar = AnonymousLocal(envPtr); if (collectVar < 0) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1447,18 +1398,9 @@ CompileDictEachCmd( } nameChars = strlen(argv[0]); - if (!TclIsLocalScalar(argv[0], nameChars)) { - ckfree(argv); - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr); - + keyVarIndex = LocalScalar(argv[0], nameChars, envPtr); nameChars = strlen(argv[1]); - if (!TclIsLocalScalar(argv[1], nameChars)) { - ckfree(argv); - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr); + valueVarIndex = LocalScalar(argv[1], nameChars, envPtr); ckfree(argv); if ((keyVarIndex < 0) || (valueVarIndex < 0)) { @@ -1472,7 +1414,7 @@ CompileDictEachCmd( * (at which point it should also have been finished with). */ - infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + infoIndex = AnonymousLocal(envPtr); if (infoIndex < 0) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1627,8 +1569,7 @@ TclCompileDictUpdateCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - const char *name; - int i, nameChars, dictIndex, numVars, range, infoIndex; + int i, dictIndex, numVars, range, infoIndex; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; DictUpdateInfo *duiPtr; JumpFixup jumpFixup; @@ -1658,15 +1599,7 @@ TclCompileDictUpdateCmd( */ dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto issueFallback; - } - name = dictVarTokenPtr[1].start; - nameChars = dictVarTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - goto issueFallback; - } - dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr); if (dictIndex < 0) { goto issueFallback; } @@ -1688,27 +1621,14 @@ TclCompileDictUpdateCmd( */ keyTokenPtrs[i] = tokenPtr; - - /* - * Variables first need to be checked for sanity. - */ - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedUpdateInfoAssembly; - } - name = tokenPtr[1].start; - nameChars = tokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - goto failedUpdateInfoAssembly; - } /* - * Stash the index in the auxiliary data. + * Stash the index in the auxiliary data (if it is indeed a local + * scalar that is resolvable at compile-time). */ - duiPtr->varIndices[i] = - TclFindCompiledLocal(name, nameChars, 1, envPtr); + duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr); if (duiPtr->varIndices[i] < 0) { goto failedUpdateInfoAssembly; } @@ -1819,19 +1739,9 @@ TclCompileDictAppendCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } else { - register const char *name = tokenPtr[1].start; - register int nameChars = tokenPtr[1].size; - - if (!TclIsLocalScalar(name, nameChars)) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr); - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); - if (dictVarIndex < 0) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr); - } + dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); + if (dictVarIndex < 0) { + return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr); } /* @@ -1866,8 +1776,7 @@ TclCompileDictLappendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; - int dictVarIndex, nameChars; - const char *name; + int dictVarIndex; /* * There must be three arguments after the command. @@ -1884,15 +1793,7 @@ TclCompileDictLappendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); keyTokenPtr = TokenAfter(varTokenPtr); valueTokenPtr = TokenAfter(keyTokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); if (dictVarIndex < 0) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1917,8 +1818,8 @@ TclCompileDictWithCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, range, varNameTmp = -1, pathTmp, keysTmp, gotPath, dictVar = -1; - int bodyIsEmpty = 1; + int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath; + int dictVar, bodyIsEmpty = 1; Tcl_Token *varTokenPtr, *tokenPtr; JumpFixup jumpFixup; const char *ptr, *end; @@ -1967,11 +1868,7 @@ TclCompileDictWithCmd( */ gotPath = (parsePtr->numWords > 3); - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD && - TclIsLocalScalar(varTokenPtr[1].start, varTokenPtr[1].size)) { - dictVar = TclFindCompiledLocal(varTokenPtr[1].start, - varTokenPtr[1].size, 1, envPtr); - } + dictVar = LocalScalarFromToken(varTokenPtr, envPtr); /* * Special case: an empty body means we definitely have no need to issue @@ -2054,14 +1951,12 @@ TclCompileDictWithCmd( */ if (dictVar == -1) { - varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + varNameTmp = AnonymousLocal(envPtr); } if (gotPath) { - pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); - } else { - pathTmp = -1; + pathTmp = AnonymousLocal(envPtr); } - keysTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + keysTmp = AnonymousLocal(envPtr); /* * Issue instructions. First, the part to expand the dictionary. @@ -2696,8 +2591,7 @@ CompileEachloopCmd( } if (collect == TCL_EACH_COLLECT) { - collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, - envPtr); + collectVar = AnonymousLocal(envPtr); if (collectVar < 0) { return TCL_ERROR; } @@ -2716,14 +2610,12 @@ CompileEachloopCmd( code = TCL_OK; firstValueTemp = -1; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, envPtr); + tempVar = AnonymousLocal(envPtr); if (loopIndex == 0) { firstValueTemp = tempVar; } } - loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, envPtr); + loopCtTemp = AnonymousLocal(envPtr); /* * Create and initialize the ForeachInfo and ForeachVarList data @@ -3455,8 +3347,7 @@ TclPushVarName( */ if (!hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, - 1, envPtr); + localIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { /* * We'll push the name. diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 7831198..381703b 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2159,12 +2159,11 @@ TclCompileTryCmd( int len; const char *varname = Tcl_GetStringFromObj(objv[0], &len); - if (!TclIsLocalScalar(varname, len)) { + resultVarIndices[i] = LocalScalar(varname, len, envPtr); + if (resultVarIndices[i] < 0) { TclDecrRefCount(tmpObj); goto failedToCompile; } - resultVarIndices[i] = - TclFindCompiledLocal(varname, len, 1, envPtr); } else { resultVarIndices[i] = -1; } @@ -2172,12 +2171,11 @@ TclCompileTryCmd( int len; const char *varname = Tcl_GetStringFromObj(objv[1], &len); - if (!TclIsLocalScalar(varname, len)) { + optionVarIndices[i] = LocalScalar(varname, len, envPtr); + if (optionVarIndices[i] < 0) { TclDecrRefCount(tmpObj); goto failedToCompile; } - optionVarIndices[i] = - TclFindCompiledLocal(varname, len, 1, envPtr); } else { optionVarIndices[i] = -1; } @@ -2289,8 +2287,8 @@ IssueTryInstructions( int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; - resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + resultVar = AnonymousLocal(envPtr); + optionsVar = AnonymousLocal(envPtr); if (resultVar < 0 || optionsVar < 0) { return TCL_ERROR; } @@ -2444,8 +2442,8 @@ IssueTryFinallyInstructions( int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; - resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + resultVar = AnonymousLocal(envPtr); + optionsVar = AnonymousLocal(envPtr); if (resultVar < 0 || optionsVar < 0) { return TCL_ERROR; } @@ -3141,7 +3139,7 @@ CompileComparisonOpCmd( return TCL_ERROR; } else { - int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + int tmpIndex = AnonymousLocal(envPtr); int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 908dceb..9af4911 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1559,6 +1559,20 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); } /* + * How to get an anonymous local variable (used for holding temporary values + * off the stack) or a local simple scalar. + */ + +#define AnonymousLocal(envPtr) \ + (TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, (envPtr))) +#define LocalScalar(chars,len,envPtr) \ + (!TclIsLocalScalar((chars), (len)) ? -1 : \ + TclFindCompiledLocal((chars), (len), /*create*/ 1, (envPtr))) +#define LocalScalarFromToken(tokenPtr,envPtr) \ + ((tokenPtr)->type != TCL_TOKEN_SIMPLE_WORD ? -1 : \ + LocalScalar((tokenPtr)[1].start, (tokenPtr)[1].size, (envPtr))) + +/* * Flags bits used by TclPushVarName. */ -- cgit v0.12 From 77789d0ff1cb366d39f99f465f385a589bd70061 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 8 Jun 2013 23:35:02 +0000 Subject: More informative comment describing INST_SYNTAX. --- generic/tclCompile.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 572f660..c361430 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -383,7 +383,8 @@ InstructionDesc const tclInstructionTable[] = { /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, - /* Compiled bytecodes to signal syntax error. */ + /* Compiled bytecodes to signal syntax error. Equivalent to returnImm + * except for the ERR_ALREADY_LOGGED flag in the interpreter. */ {"reverse", 5, 0, 1, {OPERAND_UINT4}}, /* Reverse the order of the arg elements at the top of stack */ -- cgit v0.12 From e054370d5ffba0ae4cf54604e09dec1fe22ccaa0 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 8 Jun 2013 23:43:29 +0000 Subject: Working on a better compiler for [try]; found some bugs in previous compilation code which aren't resolved yet. --- generic/tclCompCmdsSZ.c | 146 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 123 insertions(+), 23 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 381703b..f166a7a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -51,17 +51,20 @@ static void IssueSwitchJumpTable(Tcl_Interp *interp, Tcl_Token *valueTokenPtr, int numWords, Tcl_Token **bodyToken, int *bodyLines, int **bodyContLines); -static int IssueTryFinallyInstructions(Tcl_Interp *interp, +static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens, - Tcl_Token *finallyToken); -static int IssueTryInstructions(Tcl_Interp *interp, + int *optionVarIndices, Tcl_Token **handlerTokens); +static int IssueTryClausesFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens); + int *optionVarIndices, Tcl_Token **handlerTokens, + Tcl_Token *finallyToken); +static int IssueTryFinallyInstructions(Tcl_Interp *interp, + CompileEnv *envPtr, Tcl_Token *bodyToken, + Tcl_Token *finallyToken); /* * The structures below define the AuxData types defined in this file. @@ -2223,14 +2226,17 @@ TclCompileTryCmd( * Issue the bytecode. */ - if (finallyToken) { + if (!finallyToken) { + result = IssueTryClausesInstructions(interp, envPtr, bodyToken, + numHandlers, matchCodes, matchClauses, resultVarIndices, + optionVarIndices, handlerTokens); + } else if (numHandlers == 0) { result = IssueTryFinallyInstructions(interp, envPtr, bodyToken, + finallyToken); + } else { + result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken, numHandlers, matchCodes, matchClauses, resultVarIndices, optionVarIndices, handlerTokens, finallyToken); - } else { - result = IssueTryInstructions(interp, envPtr, bodyToken, numHandlers, - matchCodes, matchClauses, resultVarIndices, optionVarIndices, - handlerTokens); } /* @@ -2256,12 +2262,13 @@ TclCompileTryCmd( /* *---------------------------------------------------------------------- * - * IssueTryInstructions, IssueTryFinallyInstructions -- + * IssueTryClausesInstructions, IssueTryClausesFinallyInstructions, + * IssueTryFinallyInstructions -- * * The code generators for [try]. Split from the parsing engine for - * reasons of developer sanity, and also split between no-finally and - * with-finally cases because so many of the details of generation vary - * between the two. + * reasons of developer sanity, and also split between no-finally, + * just-finally and with-finally cases because so many of the details of + * generation vary between the three. * * The macros below make the instruction issuing easier to follow. * @@ -2269,7 +2276,7 @@ TclCompileTryCmd( */ static int -IssueTryInstructions( +IssueTryClausesInstructions( Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, @@ -2283,7 +2290,7 @@ IssueTryInstructions( DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; int savedStackDepth = envPtr->currStackDepth; - int i, j, len, forwardsNeedFixing = 0; + int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; @@ -2294,6 +2301,18 @@ IssueTryInstructions( } /* + * Check if we're supposed to trap a normal TCL_OK completion of the body. + * If not, we can handle that case much more efficiently. + */ + + for (i=0 ; icurrStackDepth; int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0; + int trapZero = 0, afterBody = 0; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; @@ -2449,6 +2479,18 @@ IssueTryFinallyInstructions( } /* + * Check if we're supposed to trap a normal TCL_OK completion of the body. + * If not, we can handle that case much more efficiently. + */ + + for (i=0 ; icurrStackDepth = savedStackDepth; BODY( bodyToken, 1); ExceptionRangeEnds(envPtr, range); - PUSH( "0"); - OP4( REVERSE, 2); - OP1( JUMP1, 4); + if (!trapZero) { + OP( END_CATCH); + STORE( resultVar); + OP( POP); + PUSH( "-level 0 -code 0"); + STORE( optionsVar); + OP( POP); + JUMP(afterBody, JUMP4); + } else { + PUSH( "0"); + OP4( REVERSE, 2); + OP1( JUMP1, 4); + } ExceptionRangeTarget(envPtr, range, catchOffset); OP( PUSH_RETURN_CODE); OP( PUSH_RESULT); @@ -2637,6 +2689,9 @@ IssueTryFinallyInstructions( * next command (or some inter-command manipulation). */ + if (!trapZero) { + FIXJUMP(afterBody); + } envPtr->currStackDepth = savedStackDepth; BODY( finallyToken, 3 + 4*numHandlers); OP( POP); @@ -2647,6 +2702,51 @@ IssueTryFinallyInstructions( return TCL_OK; } + +static int +IssueTryFinallyInstructions( + Tcl_Interp *interp, + CompileEnv *envPtr, + Tcl_Token *bodyToken, + Tcl_Token *finallyToken) +{ + DefineLineInformation; /* TIP #280 */ + int range; + + /* + * Note that this one is simple enough that we can issue it without + * needing a local variable table, making it a universal compilation. + */ + + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); + BODY( bodyToken, 1); + ExceptionRangeEnds(envPtr, range); + OP1( JUMP1, 3); + TclAdjustStackDepth(-1, envPtr); + ExceptionRangeTarget(envPtr, range, catchOffset); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( END_CATCH); + + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); + BODY( finallyToken, 3); + OP( END_CATCH); + OP( POP); + OP1( JUMP1, 3); + TclAdjustStackDepth(-1, envPtr); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( POP); + OP4( REVERSE, 2); + OP( RETURN_STK); + return TCL_OK; +} /* *---------------------------------------------------------------------- -- cgit v0.12 From a50030aabb66d09343bddd7c2e6cf846ccc010e7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 9 Jun 2013 08:15:43 +0000 Subject: Improving tests, fixed one case. --- generic/tclCompCmdsSZ.c | 71 ++++++++++++++--------- tests/error.test | 146 +++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 181 insertions(+), 36 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index f166a7a..cbe36d1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -92,10 +92,14 @@ const AuxDataType tclJumptableInfoType = { SetLineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ PushStringLiteral(envPtr, str) -#define JUMP(var,name) \ - (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr) -#define FIXJUMP(var) \ +#define JUMP4(name,var) \ + (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name##4,0,envPtr) +#define FIXJUMP4(var) \ TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) +#define JUMP1(name,var) \ + (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr) +#define FIXJUMP1(var) \ + TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) #define LOAD(idx) \ if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} #define STORE(idx) \ @@ -2326,7 +2330,7 @@ IssueTryClausesInstructions( ExceptionRangeEnds(envPtr, range); if (!trapZero) { OP( END_CATCH); - JUMP(afterBody, JUMP4); + JUMP4( JUMP, afterBody); TclAdjustStackDepth(-1, envPtr); } else { PUSH( "0"); @@ -2359,7 +2363,7 @@ IssueTryClausesInstructions( OP( DUP); PushLiteral(envPtr, buf, strlen(buf)); OP( EQ); - JUMP(notCodeJumpSource, JUMP_FALSE4); + JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { const char *p; Tcl_ListObjLength(NULL, matchClauses[i], &len); @@ -2376,7 +2380,7 @@ IssueTryClausesInstructions( p = Tcl_GetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); - JUMP(notECJumpSource, JUMP_FALSE4); + JUMP4( JUMP_FALSE, notECJumpSource); } else { notECJumpSource = -1; /* LINT */ } @@ -2400,7 +2404,7 @@ IssueTryClausesInstructions( } if (!handlerTokens[i]) { forwardsNeedFixing = 1; - JUMP(forwardsToFix[i], JUMP4); + JUMP4( JUMP, forwardsToFix[i]); } else { forwardsToFix[i] = -1; if (forwardsNeedFixing) { @@ -2409,7 +2413,7 @@ IssueTryClausesInstructions( if (forwardsToFix[j] == -1) { continue; } - FIXJUMP(forwardsToFix[j]); + FIXJUMP4(forwardsToFix[j]); forwardsToFix[j] = -1; } } @@ -2417,11 +2421,11 @@ IssueTryClausesInstructions( BODY( handlerTokens[i], 5+i*4); } - JUMP(addrsToFix[i], JUMP4); + JUMP4( JUMP, addrsToFix[i]); if (matchClauses[i]) { - FIXJUMP(notECJumpSource); + FIXJUMP4( notECJumpSource); } - FIXJUMP(notCodeJumpSource); + FIXJUMP4( notCodeJumpSource); } /* @@ -2441,10 +2445,10 @@ IssueTryClausesInstructions( */ if (!trapZero) { - FIXJUMP(afterBody); + FIXJUMP4(afterBody); } for (i=0 ; icurrStackDepth = savedStackDepth; BODY( finallyToken, 3 + 4*numHandlers); @@ -2711,7 +2715,7 @@ IssueTryFinallyInstructions( Tcl_Token *finallyToken) { DefineLineInformation; /* TIP #280 */ - int range; + int range, jumpOK, jumpSplice; /* * Note that this one is simple enough that we can issue it without @@ -2734,15 +2738,28 @@ IssueTryFinallyInstructions( OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); BODY( finallyToken, 3); + ExceptionRangeEnds(envPtr, range); OP( END_CATCH); OP( POP); - OP1( JUMP1, 3); - TclAdjustStackDepth(-1, envPtr); + JUMP1( JUMP, jumpOK); + ExceptionRangeTarget(envPtr, range, catchOffset); OP( PUSH_RESULT); OP( PUSH_RETURN_OPTIONS); OP( PUSH_RETURN_CODE); OP( END_CATCH); + PUSH( "1"); + OP( EQ); + JUMP1( JUMP_FALSE, jumpSplice); + PUSH( "-during"); + OP4( OVER, 3); + OP4( LIST, 2); + OP( LIST_CONCAT); + FIXJUMP1( jumpSplice); + OP4( REVERSE, 4); + OP( POP); OP( POP); + OP1( JUMP1, 7); + FIXJUMP1( jumpOK); OP4( REVERSE, 2); OP( RETURN_STK); return TCL_OK; diff --git a/tests/error.test b/tests/error.test index 97bcc0a..273577a 100644 --- a/tests/error.test +++ b/tests/error.test @@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } testConstraint memory [llength [info commands memory]] +customMatch pairwise {apply {{a b} { + string equal [lindex $b 0] [lindex $b 1] +}}} namespace eval ::tcl::test::error { if {[testConstraint memory]} { proc getbytes {} { @@ -601,21 +604,21 @@ test error-16.7 {try with variable assignment and propagation #2} { } list $em [dict get $opts -errorcode] } {bar FOO} -test error-16.8 {exception chaining (try=ok, handler=error)} { +test error-16.8 {exception chaining (try=ok, handler=error)} -body { #FIXME is the intent of this test correct? catch { try { list a b c } on ok {em opts} { throw BAR baz } } tryem tryopts - string equal $opts [dict get $tryopts -during] -} {1} -test error-16.9 {exception chaining (try=error, handler=error)} { + list $opts [dict get $tryopts -during] +} -match pairwise -result equal +test error-16.9 {exception chaining (try=error, handler=error)} -body { # The exception off the handler should chain to the exception off the # try-body (using the -during option) catch { try { throw FOO bar } trap {} {em opts} { throw BAR baz } } tryem tryopts - string equal $opts [dict get $tryopts -during] -} {1} + list $opts [dict get $tryopts -during] +} -match pairwise -result equal test error-16.10 {no exception chaining when handler is successful} { catch { try { throw FOO bar } trap {} {em opts} { list d e f } @@ -628,6 +631,131 @@ test error-16.11 {no exception chaining when handler is a non-error exception} { } tryem tryopts dict exists $tryopts -during } {0} +test error-16.12 {compiled try with successfully executed handler} { + apply {{} { + try { throw FOO bar } trap FOO {} { list a b c } + }} +} {a b c} +test error-16.13 {compiled try with exception (error) in handler} -body { + apply {{} { + try { throw FOO bar } trap FOO {} { throw BAR foo } + }} +} -returnCodes error -result {foo} +test error-16.14 {compiled try with exception (return) in handler} -body { + apply {{} { + list [catch { + try { throw FOO bar } trap FOO {} { return BAR } + } msg] $msg + }} +} -result {2 BAR} +test error-16.15 {compiled try with exception (break) in handler} { + apply {{} { + for { set i 5 } { $i < 10 } { incr i } { + try { throw FOO bar } trap FOO {} { break } + } + return $i + }} +} {5} +test error-16.16 {compiled try with exception (continue) in handler} { + apply {{} { + for { set i 5 } { $i < 10 } { incr i } { + try { throw FOO bar } trap FOO {} { continue } + incr i 20 + } + return $i + }} +} {10} +test error-16.17 {compiled try with variable assignment and propagation #1} { + # Ensure that the handler variables preserve the exception off the + # try-body, and are not modified by the exception off the handler + apply {{} { + catch { + try { throw FOO bar } trap FOO {em} { throw BAR baz } + } + return $em + }} +} {bar} +test error-16.18 {compiled try with variable assignment and propagation #2} { + apply {{} { + catch { + try { throw FOO bar } trap FOO {em opts} { throw BAR baz } + } + list $em [dict get $opts -errorcode] + }} +} {bar FOO} +test error-16.19 {compiled try exception chaining (try=ok, handler=error)} -body { + #FIXME is the intent of this test correct? + apply {{} { + catch { + try { list a b c } on ok {em opts} { throw BAR baz } + } tryem tryopts + list $opts [dict get $tryopts -during] + }} +} -match pairwise -result equal +test error-16.20 {compiled try exception chaining (try=error, handler=error)} -body { + # The exception off the handler should chain to the exception off the + # try-body (using the -during option) + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { throw BAR baz } + } tryem tryopts + list $opts [dict get $tryopts -during] + }} +} -match pairwise -result equal +test error-16.21 {compiled try exception chaining (try=error, finally=error)} { + # The exception off the handler should chain to the exception off the + # try-body (using the -during option) + apply {{} { + catch { + try { throw FOO bar } finally { throw BAR baz } + } tryem tryopts + dict get $tryopts -during -errorcode + }} +} FOO +test error-16.22 {compiled try: no exception chaining when handler is successful} { + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { list d e f } + } tryem tryopts + dict exists $tryopts -during + }} +} {0} +test error-16.23 {compiled try: no exception chaining when handler is a non-error exception} { + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { break } + } tryem tryopts + dict exists $tryopts -during + }} +} {0} +test error-16.24 {compiled try exception chaining (try=ok, handler=error, finally=error)} -body { + apply {{} { + catch { + try { + list a b c + } on ok {em opts} { + throw BAR baz + } finally { + throw DING dong + } + } tryem tryopts + list $opts [dict get $tryopts -during -during] + }} +} -match pairwise -result equal +test error-16.25 {compiled try exception chaining (all errors)} -body { + apply {{} { + catch { + try { + throw FOO bar + } on error {em opts} { + throw BAR baz + } finally { + throw DING dong + } + } tryem tryopts + list $opts [dict get $tryopts -during -during] + }} +} -match pairwise -result equal # try tests - finally @@ -709,15 +837,15 @@ test error-18.5 {exception in finally doesn't affect variable assignment} { } list $em [dict get $opts -errorcode] } {bar FOO} -test error-18.6 {exception chaining in finally (try=ok)} { +test error-18.6 {exception chaining in finally (try=ok)} -body { catch { list a b c } em expopts catch { try { list a b c } finally { throw BAR foo } } em opts - string equal $expopts [dict get $opts -during] -} {1} + list $expopts [dict get $opts -during] +} -match pairwise -result equal test error-18.7 {exception chaining in finally (try=error)} { catch { try { throw FOO bar } finally { throw BAR baz } -- cgit v0.12 From c5f23415aa4481746a0e6127f92fc112a9594068 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 9 Jun 2013 17:21:07 +0000 Subject: Fix the problems with code generation; behavior now appears correct. --- generic/tclCompCmdsSZ.c | 333 +++++++++++++++++++++++++++++------------------- 1 file changed, 204 insertions(+), 129 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index cbe36d1..5d67166 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2293,9 +2293,9 @@ IssueTryClausesInstructions( { DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; - int savedStackDepth = envPtr->currStackDepth; int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; + int *noError; char buf[TCL_INTEGER_SPACE]; resultVar = AnonymousLocal(envPtr); @@ -2357,8 +2357,10 @@ IssueTryClausesInstructions( addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); + noError = TclStackAlloc(interp, sizeof(int)*numHandlers); for (i=0 ; icurrStackDepth = savedStackDepth; + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); BODY( handlerTokens[i], 5+i*4); + ExceptionRangeEnds(envPtr, range); + OP( END_CATCH); + JUMP4( JUMP, noError[i]); + ExceptionRangeTarget(envPtr, range, catchOffset); + TclAdjustStackDepth(-1, envPtr); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + PUSH( "1"); + OP( EQ); + JUMP1( JUMP_FALSE, dontChangeOptions); + LOAD( optionsVar); + OP4( REVERSE, 2); + STORE( optionsVar); + OP( POP); + PUSH( "-during"); + OP4( REVERSE, 2); + OP44( DICT_SET, 1, optionsVar); + TclAdjustStackDepth(-1, envPtr); + FIXJUMP1( dontChangeOptions); + OP4( REVERSE, 2); + OP( RETURN_STK); } JUMP4( JUMP, addrsToFix[i]); @@ -2449,10 +2478,13 @@ IssueTryClausesInstructions( } for (i=0 ; icurrStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -2470,9 +2502,8 @@ IssueTryClausesFinallyInstructions( Tcl_Token *finallyToken) /* Not NULL */ { DefineLineInformation; /* TIP #280 */ - int savedStackDepth = envPtr->currStackDepth; int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0; - int trapZero = 0, afterBody = 0; + int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; @@ -2502,7 +2533,6 @@ IssueTryClausesFinallyInstructions( range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); - envPtr->currStackDepth = savedStackDepth; BODY( bodyToken, 1); ExceptionRangeEnds(envPtr, range); if (!trapZero) { @@ -2517,6 +2547,7 @@ IssueTryClausesFinallyInstructions( PUSH( "0"); OP4( REVERSE, 2); OP1( JUMP1, 4); + TclAdjustStackDepth(-2, envPtr); } ExceptionRangeTarget(envPtr, range, catchOffset); OP( PUSH_RETURN_CODE); @@ -2527,163 +2558,178 @@ IssueTryClausesFinallyInstructions( OP( POP); STORE( resultVar); OP( POP); - envPtr->currStackDepth = savedStackDepth + 1; /* * Now we handle all the registered 'on' and 'trap' handlers in order. + * + * Slight overallocation, but reduces size of this function. */ - if (numHandlers) { - /* - * Slight overallocation, but reduces size of this function. - */ - - addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - - for (i=0 ; i= 0 || handlerTokens[i]) { - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - } - if (resultVars[i] >= 0) { - LOAD( resultVar); - STORE( resultVars[i]); - OP( POP); - if (optionVars[i] >= 0) { - LOAD( optionsVar); - STORE( optionVars[i]); - OP( POP); - } + LOAD( optionsVar); + PUSH( "-errorcode"); + OP4( DICT_GET, 1); + TclAdjustStackDepth(-1, envPtr); + OP44( LIST_RANGE_IMM, 0, len-1); + p = Tcl_GetStringFromObj(matchClauses[i], &len); + PushLiteral(envPtr, p, len); + OP( STR_EQ); + JUMP4( JUMP_FALSE, notECJumpSource); + } else { + notECJumpSource = -1; /* LINT */ + } + OP( POP); - if (!handlerTokens[i]) { - /* - * No handler. Will not be the last handler (that is a - * condition that is checked by the caller). Chain to the - * next one. - */ + /* + * There is a finally clause, so we need a fairly complex sequence of + * instructions to deal with an on/trap handler because we must call + * the finally handler *and* we need to substitute the result from a + * failed trap for the result from the main script. + */ - ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); - forwardsNeedFixing = 1; - JUMP4( JUMP, forwardsToFix[i]); - goto finishTrapCatchHandling; - } - } else if (!handlerTokens[i]) { + if (resultVars[i] >= 0 || handlerTokens[i]) { + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); + } + if (resultVars[i] >= 0) { + LOAD( resultVar); + STORE( resultVars[i]); + OP( POP); + if (optionVars[i] >= 0) { + LOAD( optionsVar); + STORE( optionVars[i]); + OP( POP); + } + + if (!handlerTokens[i]) { /* - * No handler. Will not be the last handler (that condition is - * checked by the caller). Chain to the next one. + * No handler. Will not be the last handler (that is a + * condition that is checked by the caller). Chain to the next + * one. */ + ExceptionRangeEnds(envPtr, range); + OP( END_CATCH); forwardsNeedFixing = 1; JUMP4( JUMP, forwardsToFix[i]); - goto endOfThisArm; + goto finishTrapCatchHandling; } - + } else if (!handlerTokens[i]) { /* - * Got a handler. Make sure that any pending patch-up actions from - * previous unprocessed handlers are dealt with now that we know - * where they are to jump to. + * No handler. Will not be the last handler (that condition is + * checked by the caller). Chain to the next one. */ - if (forwardsNeedFixing) { - forwardsNeedFixing = 0; - OP1( JUMP1, 7); - for (j=0 ; jcurrStackDepth = savedStackDepth; - BODY( handlerTokens[i], 5+i*4); - ExceptionRangeEnds(envPtr, range); - OP( PUSH_RETURN_OPTIONS); - OP4( REVERSE, 2); - OP1( JUMP1, 4); - forwardsToFix[i] = -1; - - /* - * Error in handler or setting of variables; replace the stored - * exception with the new one. Note that we only push this if we - * have either a body or some variable setting here. Otherwise - * this code is unreachable. - */ + forwardsNeedFixing = 1; + JUMP4( JUMP, forwardsToFix[i]); + goto endOfThisArm; + } - finishTrapCatchHandling: - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RESULT); - OP( END_CATCH); - STORE( resultVar); - OP( POP); - STORE( optionsVar); - OP( POP); + /* + * Got a handler. Make sure that any pending patch-up actions from + * previous unprocessed handlers are dealt with now that we know where + * they are to jump to. + */ - endOfThisArm: - if (i+1 < numHandlers) { - JUMP4( JUMP, addrsToFix[i]); - } - if (matchClauses[i]) { - FIXJUMP4(notECJumpSource); + if (forwardsNeedFixing) { + forwardsNeedFixing = 0; + OP1( JUMP1, 7); + for (j=0 ; jcurrStackDepth = savedStackDepth; + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); BODY( finallyToken, 3 + 4*numHandlers); + ExceptionRangeEnds(envPtr, range); + OP( END_CATCH); OP( POP); + JUMP1( JUMP, finalOK); + ExceptionRangeTarget(envPtr, range, catchOffset); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + PUSH( "1"); + OP( EQ); + JUMP1( JUMP_FALSE, noFinalError); + LOAD( optionsVar); + PUSH( "-during"); + OP4( REVERSE, 3); + STORE( optionsVar); + OP( POP); + OP44( DICT_SET, 1, optionsVar); + TclAdjustStackDepth(-1, envPtr); + OP( POP); + JUMP1( JUMP, finalError); + TclAdjustStackDepth(1, envPtr); + FIXJUMP1( noFinalError); + STORE( optionsVar); + OP( POP); + FIXJUMP1( finalError); + STORE( resultVar); + OP( POP); + FIXJUMP1( finalOK); LOAD( optionsVar); LOAD( resultVar); OP( RETURN_STK); - envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } -- cgit v0.12 From a9614d87b805cb106c4876c73858300e3c4359a3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Jun 2013 07:58:01 +0000 Subject: Improve compatibility detection for and : - Move before other includes on Windows, so we are sure the time_t definition being checked doesn't come from . - Padding at the end of Tcl_StatBuf doesn't influcence binary compatibility, so relax panic check accordingly. --- generic/tclBasic.c | 7 ++++--- win/tclWinPort.h | 3 +-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5e6b500..4f24515 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -413,11 +413,12 @@ Tcl_CreateInterp(void) #if defined(_WIN32) && !defined(_WIN64) if (sizeof(time_t) != 4) { /*NOTREACHED*/ - Tcl_Panic("sys/time.h is not compatible with MSVC"); + Tcl_Panic(" is not compatible with MSVC"); } - if (sizeof(Tcl_StatBuf) != 48) { + if ((TclOffset(Tcl_StatBuf,st_atime) != 32) + || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) { /*NOTREACHED*/ - Tcl_Panic("sys/stat.h is not compatible with MSVC"); + Tcl_Panic(" is not compatible with MSVC"); } #endif diff --git a/win/tclWinPort.h b/win/tclWinPort.h index f58014c..987d45b 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -51,6 +51,7 @@ typedef DWORD_PTR * PDWORD_PTR; *--------------------------------------------------------------------------- */ +#include #include #include #include @@ -85,8 +86,6 @@ typedef DWORD_PTR * PDWORD_PTR; # endif /* __BORLANDC__ */ #endif /* __MWERKS__ */ -#include - /* * Define EINPROGRESS in terms of WSAEINPROGRESS. */ -- cgit v0.12 From eee0c67ac8f3ae799c0222a6b0c4ad25c757b7e5 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Jun 2013 16:44:34 +0000 Subject: [33b7abb8a2] [7174354ecb] Rewrite TclCompileThrowCmd(). --- generic/tclCompCmdsSZ.c | 105 +++++++++++++++++++++--------------------------- tests/error.test | 6 +++ 2 files changed, 52 insertions(+), 59 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 5d67166..b9ee1d4 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1942,9 +1942,9 @@ TclCompileThrowCmd( { DefineLineInformation; /* TIP #280 */ int numWords = parsePtr->numWords; - int savedStackDepth = envPtr->currStackDepth; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; + int codeKnown, codeIsList, codeIsValid, len; if (numWords != 3) { return TCL_ERROR; @@ -1954,77 +1954,64 @@ TclCompileThrowCmd( TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); - if (TclWordKnownAtCompileTime(codeToken, objPtr)) { - Tcl_Obj *errPtr, *dictPtr; - const char *string; - int len; - /* - * The code is known at compilation time. This allows us to issue a - * very efficient sequence of instructions. - */ + codeKnown = TclWordKnownAtCompileTime(codeToken, objPtr); - if (Tcl_ListObjLength(interp, objPtr, &len) != TCL_OK) { - /* - * Must still do this; might generate an error when getting this - * "ignored" value prepared as an argument. - */ + /* + * First we must emit the code to substitute the arguments. This + * must come first in case substitution raises errors. + */ + if (!codeKnown) { + CompileWord(envPtr, codeToken, interp, 1); + PUSH( "-errorcode"); + } + CompileWord(envPtr, msgToken, interp, 2); - CompileWord(envPtr, msgToken, interp, 2); - TclCompileSyntaxError(interp, envPtr); - Tcl_DecrRefCount(objPtr); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; - } - if (len == 0) { - /* - * Must still do this; might generate an error when getting this - * "ignored" value prepared as an argument. - */ + codeIsList = codeKnown && (TCL_OK == + Tcl_ListObjLength(interp, objPtr, &len)); + codeIsValid = codeIsList && (len != 0); + + if (codeIsValid) { + Tcl_Obj *errPtr, *dictPtr; - CompileWord(envPtr, msgToken, interp, 2); - goto issueErrorForEmptyCode; - } TclNewLiteralStringObj(errPtr, "-errorcode"); TclNewObj(dictPtr); Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr); - Tcl_IncrRefCount(dictPtr); - string = Tcl_GetStringFromObj(dictPtr, &len); - CompileWord(envPtr, msgToken, interp, 2); - PushLiteral(envPtr, string, len); - TclDecrRefCount(dictPtr); - OP44( RETURN_IMM, 1, 0); - envPtr->currStackDepth = savedStackDepth + 1; - } else { - /* - * When the code token is not known at compilation time, we need to do - * a little bit more work. The main tricky bit here is that the error - * code has to be a list (a [throw] restriction) so we must emit extra - * instructions to enforce that condition. - */ + TclEmitPush(TclAddLiteralObj(envPtr, dictPtr, NULL), envPtr); + } + TclDecrRefCount(objPtr); - CompileWord(envPtr, codeToken, interp, 1); - PUSH( "-errorcode"); - CompileWord(envPtr, msgToken, interp, 2); - OP4( REVERSE, 3); - OP( DUP); - OP( LIST_LENGTH); - OP1( JUMP_FALSE1, 16); - OP4( LIST, 2); - OP44( RETURN_IMM, 1, 0); + /* + * Simpler bytecodes when we detect invalid arguments at compile time. + */ + if (codeKnown && !codeIsValid) { + OP( POP); + if (codeIsList) { + /* Must be an empty list */ + goto issueErrorForEmptyCode; + } + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; + } + if (!codeKnown) { /* - * Generate an error for being an empty list. Can't leverage anything - * else to do this for us. + * Argument validity checking has to be done by bytecode at + * run time. */ - + OP4( REVERSE, 3); + OP( DUP); + OP( LIST_LENGTH); + OP1( JUMP_FALSE1, 16); + OP4( LIST, 2); + OP44( RETURN_IMM, 1, 0); + OP( POP); + OP( POP); issueErrorForEmptyCode: - PUSH( "type must be non-empty list"); - PUSH( ""); - OP44( RETURN_IMM, 1, 0); + PUSH( "type must be non-empty list"); + PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}"); } - envPtr->currStackDepth = savedStackDepth + 1; - TclDecrRefCount(objPtr); + OP44( RETURN_IMM, 1, 0); return TCL_OK; } diff --git a/tests/error.test b/tests/error.test index 273577a..06f8eca 100644 --- a/tests/error.test +++ b/tests/error.test @@ -317,6 +317,12 @@ test error-8.8 {throw syntax checks} -returnCodes error -body { test error-8.9 {throw syntax checks} -returnCodes error -body { throw {} foo } -result {type must be non-empty list} +test error-8.10 {Bug 33b7abb8a2: throw stack usage} -returnCodes error -body { + apply {code {throw $code foo}} {} +} -result {type must be non-empty list} +test error-8.11 {Bug 7174354ecb: throw error message} -returnCodes error -body { + throw {not {}a list} x[]y +} -result {list element in braces followed by "a" instead of space} # simple try tests: body completes with code ok -- cgit v0.12 From d29536641dcd82c9373cc5835f9fd879194620e8 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Jun 2013 17:58:49 +0000 Subject: Stack housekeeping repair for last checkin. --- generic/tclCompCmdsSZ.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index b9ee1d4..6897b9b 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2005,6 +2005,8 @@ TclCompileThrowCmd( OP1( JUMP_FALSE1, 16); OP4( LIST, 2); OP44( RETURN_IMM, 1, 0); + TclAdjustStackDepth(2, envPtr); + OP( POP); OP( POP); OP( POP); issueErrorForEmptyCode: -- cgit v0.12 From 236502157da38dfe3835d0daf426c2d2a0664160 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Jun 2013 19:41:55 +0000 Subject: Repairs to compile/exec debugging output. --- generic/tclCompile.c | 7 ++++++- generic/tclExecute.c | 17 ++++++++++------- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c361430..f6e0554 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1232,7 +1232,12 @@ CompileSubstObj( codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } - /* TODO: Debug printing? */ +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + fflush(stdout); + } +#endif /* TCL_COMPILE_DEBUG */ } return codePtr; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 443fb85..f5737b5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2320,7 +2320,7 @@ TEBCresume( goto instLoadScalar1; } else if (inst == INST_PUSH1) { PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS); + TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS); inst = *(pc += 2); goto peepholeStart; } else if (inst == INST_START_CMD) { @@ -2362,7 +2362,7 @@ TEBCresume( TRACE(("%u %u => ", code, level)); result = TclProcessReturn(interp, code, level, OBJ_AT_TOS); if (result == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", O2S(objResultPtr))); NEXT_INST_F(9, 1, 0); } @@ -2371,6 +2371,7 @@ TEBCresume( iPtr->flags &= ~ERR_ALREADY_LOGGED; } cleanup = 2; + TRACE_APPEND(("\n")); goto processExceptionReturn; } @@ -2381,7 +2382,7 @@ TEBCresume( if (result == TCL_OK) { Tcl_DecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = objResultPtr; - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", O2S(objResultPtr))); NEXT_INST_F(1, 0, 0); } else if (result == TCL_ERROR) { @@ -2401,6 +2402,7 @@ TEBCresume( Tcl_SetObjResult(interp, objResultPtr); } cleanup = 1; + TRACE_APPEND(("\n")); goto processExceptionReturn; case INST_YIELD: { @@ -3662,7 +3664,7 @@ TEBCresume( arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %ld => ", opnd, increment)); + TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr))); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { @@ -4227,7 +4229,7 @@ TEBCresume( } else { TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); + (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); } } #endif @@ -6610,7 +6612,7 @@ TEBCresume( } #endif - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", + 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 */ @@ -6624,7 +6626,7 @@ TEBCresume( while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); + TRACE(("%u => \n", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { @@ -6753,6 +6755,7 @@ TEBCresume( O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); goto gotError; } + TRACE((" => ")); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); -- cgit v0.12 From 9ca9c6da3a55c6358a221f006c6cc846bd8d9922 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Jun 2013 20:38:00 +0000 Subject: Select improvements in stack depth estimates brought over from mig-review. Mostly these are just simplifications, removing code that wasn't needed. Some changes make the stack depth estimate more accurate instruction by instruction. --- generic/tclCompCmds.c | 26 ++++---------------------- generic/tclCompCmdsGR.c | 15 +-------------- generic/tclCompCmdsSZ.c | 34 ++++++---------------------------- generic/tclCompExpr.c | 1 + generic/tclCompile.c | 12 +++++------- 5 files changed, 17 insertions(+), 71 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 25c4bac..fddf152 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -545,7 +545,6 @@ TclCompileCatchCmd( Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; int resultIndex, optsIndex, range; int initStackDepth = envPtr->currStackDepth; - int savedStackDepth; DefineLineInformation; /* TIP #280 */ /* @@ -613,13 +612,11 @@ TclCompileCatchCmd( SetLineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - savedStackDepth = envPtr->currStackDepth; TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, cmdTokenPtr, interp); } else { CompileTokens(envPtr, cmdTokenPtr, interp); - savedStackDepth = envPtr->currStackDepth; TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); TclEmitOpcode( INST_DUP, envPtr); @@ -641,7 +638,7 @@ TclCompileCatchCmd( TclEmitOpcode( INST_POP, envPtr); PushStringLiteral(envPtr, "0"); TclEmitInstInt1( INST_JUMP1, 3, envPtr); - envPtr->currStackDepth = savedStackDepth; + TclAdjustStackDepth(-1, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); ExceptionRangeEnds(envPtr, range); @@ -670,7 +667,7 @@ TclCompileCatchCmd( * return code. */ - envPtr->currStackDepth = savedStackDepth; + TclAdjustStackDepth(-2, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); /* Stack at this point: ?script? */ TclEmitOpcode( INST_PUSH_RESULT, envPtr); @@ -1286,6 +1283,7 @@ TclCompileDictMergeCmd( * subsequent) dicts. This is strictly not necessary, but it is nice. */ + TclAdjustStackDepth(-1, envPtr); ExceptionRangeTarget(envPtr, outLoop, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); @@ -1295,7 +1293,6 @@ TclCompileDictMergeCmd( TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); - TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1345,9 +1342,6 @@ CompileDictEachCmd( int numVars, endTargetOffset; int collectVar = -1; /* Index of temp var holding the result * dict. */ - int savedStackDepth = envPtr->currStackDepth; - /* Needed because jumps confuse the stack - * space calculator. */ const char **argv; Tcl_DString buffer; @@ -1510,6 +1504,7 @@ CompileDictEachCmd( * and rethrows the error. */ + TclAdjustStackDepth(-1, envPtr); ExceptionRangeTarget(envPtr, catchRange, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); @@ -1528,7 +1523,6 @@ CompileDictEachCmd( * easy!) Note that we skip the END_CATCH. [Bug 1382528] */ - envPtr->currStackDepth = savedStackDepth + 2; jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + emptyTargetOffset); @@ -2240,7 +2234,6 @@ TclCompileForCmd( JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; - int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 5) { @@ -2302,7 +2295,6 @@ TclCompileForCmd( SetLineInformation(4); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); - envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* @@ -2313,14 +2305,11 @@ TclCompileForCmd( nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; - envPtr->currStackDepth = savedStackDepth; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); SetLineInformation(3); CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); - envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); - envPtr->currStackDepth = savedStackDepth; /* * Compile the test expression then emit the conditional jump that @@ -2337,9 +2326,7 @@ TclCompileForCmd( } SetLineInformation(2); - envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { @@ -2367,7 +2354,6 @@ TclCompileForCmd( * The for command's result is an empty string. */ - envPtr->currStackDepth = savedStackDepth; PushStringLiteral(envPtr, ""); return TCL_OK; @@ -2480,7 +2466,6 @@ CompileEachloopCmd( JumpFixup jumpFalseFixup; int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; - int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ /* @@ -2703,7 +2688,6 @@ CompileEachloopCmd( ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); - envPtr->currStackDepth = savedStackDepth + 1; if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); @@ -2763,7 +2747,6 @@ CompileEachloopCmd( * list of results from evaluating the loop body. */ - envPtr->currStackDepth = savedStackDepth; if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); @@ -2771,7 +2754,6 @@ CompileEachloopCmd( } else { PushStringLiteral(envPtr, ""); } - envPtr->currStackDepth = savedStackDepth + 1; done: for (loopIndex = 0; loopIndex < numLists; loopIndex++) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 5e3d456..f7c15e6 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -142,10 +142,6 @@ TclCompileIfCmd( int jumpIndex = 0; /* Avoid compiler warning. */ int jumpFalseDist, numWords, wordIdx, numBytes, j, code; const char *word; - int savedStackDepth = envPtr->currStackDepth; - /* Saved stack depth at the start of the first - * test; the envPtr current depth is restored - * to this value at the start of each test. */ int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ int boolVal; /* Value of static condition. */ @@ -203,7 +199,6 @@ TclCompileIfCmd( * the "then" part. */ - envPtr->currStackDepth = savedStackDepth; testTokenPtr = tokenPtr; if (realCond) { @@ -270,7 +265,6 @@ TclCompileIfCmd( if (compileScripts) { SetLineInformation(wordIdx); - envPtr->currStackDepth = savedStackDepth; CompileBody(envPtr, tokenPtr, interp); } @@ -295,6 +289,7 @@ TclCompileIfCmd( * with a 4 byte jump. */ + TclAdjustStackDepth(-1, envPtr); if (TclFixupForwardJumpToHere(envPtr, jumpFalseFixupArray.fixup+jumpIndex, 120)) { /* @@ -325,13 +320,6 @@ TclCompileIfCmd( } /* - * Restore the current stack depth in the environment; the "else" clause - * (or its default) will add 1 to this. - */ - - envPtr->currStackDepth = savedStackDepth; - - /* * Check for the optional else clause. Do not compile anything if this was * an "if 1 {...}" case. */ @@ -416,7 +404,6 @@ TclCompileIfCmd( */ done: - envPtr->currStackDepth = savedStackDepth + 1; TclFreeJumpFixupArray(&jumpFalseFixupArray); TclFreeJumpFixupArray(&jumpEndFixupArray); return code; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 6897b9b..855dd8f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -865,6 +865,7 @@ TclSubstCompile( /* Substitution produced TCL_OK */ OP( END_CATCH); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); + TclAdjustStackDepth(-1, envPtr); /* Exceptional return codes processed here */ ExceptionRangeTarget(envPtr, catchRange, catchOffset); @@ -890,6 +891,7 @@ TclSubstCompile( /* OTHER */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); + TclAdjustStackDepth(1, envPtr); /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", @@ -905,6 +907,7 @@ TclSubstCompile( OP1(JUMP1, -breakJump); } + TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", @@ -914,6 +917,7 @@ TclSubstCompile( OP( POP); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); + TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", @@ -931,17 +935,6 @@ TclSubstCompile( OP4( REVERSE, 2); OP( POP); - /* - * We've emitted several POP instructions, and the automatic - * computations for stack depth requirements have been decrementing - * for every one. However, we know that every branch actually taken - * only encounters some of those instructions. No branch passes - * through them all. So, we now have a stack requirements estimate - * that is too low. Here we manually fix that up. - */ - - TclAdjustStackDepth(4, envPtr); - /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", @@ -1353,7 +1346,6 @@ IssueSwitchChainedTests( int **bodyContLines) /* Array of continuation line info. */ { enum {Switch_Exact, Switch_Glob, Switch_Regexp}; - int savedStackDepth = envPtr->currStackDepth; int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ @@ -1388,7 +1380,6 @@ IssueSwitchChainedTests( foundDefault = 0; for (i=0 ; icurrStackDepth = savedStackDepth + 1; if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 || memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { /* @@ -1525,7 +1516,6 @@ IssueSwitchChainedTests( */ OP( POP); - envPtr->currStackDepth = savedStackDepth; envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); @@ -1583,8 +1573,6 @@ IssueSwitchChainedTests( } TclStackFree(interp, fixupTargetArray); TclStackFree(interp, fixupArray); - - envPtr->currStackDepth = savedStackDepth + 1; } /* @@ -1618,7 +1606,6 @@ IssueSwitchJumpTable( int **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; - int savedStackDepth = envPtr->currStackDepth; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; int mustGenerate, foundDefault, jumpToDefault, i; Tcl_DString buffer; @@ -1731,7 +1718,6 @@ IssueSwitchJumpTable( * Compile the body of the arm. */ - envPtr->currStackDepth = savedStackDepth; envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); @@ -1753,6 +1739,7 @@ IssueSwitchJumpTable( */ OP4( JUMP4, 0); + TclAdjustStackDepth(-1, envPtr); } } @@ -1763,7 +1750,6 @@ IssueSwitchJumpTable( */ if (!foundDefault) { - envPtr->currStackDepth = savedStackDepth; TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, envPtr->codeStart+jumpToDefault+1); PUSH(""); @@ -1784,7 +1770,6 @@ IssueSwitchJumpTable( */ TclStackFree(interp, finalFixups); - envPtr->currStackDepth = savedStackDepth + 1; } /* @@ -2692,15 +2677,13 @@ IssueTryClausesFinallyInstructions( /* Skip POP at end; can clean up with subsequent POP */ if (i+1 < numHandlers) { OP( POP); - } else { - TclAdjustStackDepth(-1, envPtr); } endOfThisArm: if (i+1 < numHandlers) { JUMP4( JUMP, addrsToFix[i]); + TclAdjustStackDepth(1, envPtr); } - TclAdjustStackDepth(1, envPtr); if (matchClauses[i]) { FIXJUMP4( notECJumpSource); } @@ -2954,7 +2937,6 @@ TclCompileWhileCmd( Tcl_Token *testTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; - int savedStackDepth = envPtr->currStackDepth; int loopMayEnd = 1; /* This is set to 0 if it is recognized as an * infinite loop. */ Tcl_Obj *boolObj; @@ -3054,7 +3036,6 @@ TclCompileWhileCmd( } CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); - envPtr->currStackDepth = savedStackDepth + 1; OP( POP); /* @@ -3069,10 +3050,8 @@ TclCompileWhileCmd( bodyCodeOffset += 3; testCodeOffset += 3; } - envPtr->currStackDepth = savedStackDepth; SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { @@ -3103,7 +3082,6 @@ TclCompileWhileCmd( */ pushResult: - envPtr->currStackDepth = savedStackDepth; PUSH(""); return TCL_OK; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 3597abe..efdc2b0 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2401,6 +2401,7 @@ CompileExprTree( (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->next->jump); + TclAdjustStackDepth(-1, envPtr); TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { jumpPtr->next->next->jump.codeOffset += 3; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f6e0554..be5bedf 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2009,8 +2009,7 @@ TclCompileScript( #ifdef TCL_COMPILE_DEBUG int diff = envPtr->currStackDepth-startStackDepth; - if (diff != 1 && (diff != 0 || - *(envPtr->codeNext-1) != INST_DONE)) { + if (diff != 1) { Tcl_Panic("bad stack adjustment when compiling" " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, @@ -2628,12 +2627,10 @@ TclCompileNoOp( { Tcl_Token *tokenPtr; int i; - int savedStackDepth = envPtr->currStackDepth; tokenPtr = parsePtr->tokenPtr; for (i = 1; i < parsePtr->numWords; i++) { tokenPtr = tokenPtr + tokenPtr->numComponents + 1; - envPtr->currStackDepth = savedStackDepth; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, @@ -2641,7 +2638,6 @@ TclCompileNoOp( TclEmitOpcode(INST_POP, envPtr); } } - envPtr->currStackDepth = savedStackDepth; TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); return TCL_OK; } @@ -3439,6 +3435,7 @@ TclCleanupStackForBreakContinue( CompileEnv *envPtr, ExceptionAux *auxPtr) { + int savedStackDepth = envPtr->currStackDepth; int toPop = envPtr->expandCount - auxPtr->expandTarget; if (toPop > 0) { @@ -3446,20 +3443,21 @@ TclCleanupStackForBreakContinue( TclEmitOpcode(INST_EXPAND_DROP, envPtr); toPop--; } + TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, + envPtr); toPop = auxPtr->expandTargetDepth - auxPtr->stackDepth; while (toPop > 0) { TclEmitOpcode(INST_POP, envPtr); - TclAdjustStackDepth(1, envPtr); toPop--; } } else { toPop = envPtr->currStackDepth - auxPtr->stackDepth; while (toPop > 0) { TclEmitOpcode(INST_POP, envPtr); - TclAdjustStackDepth(1, envPtr); toPop--; } } + envPtr->currStackDepth = savedStackDepth; } /* -- cgit v0.12 From b028eea89ffe9a3c009dff8b8f7dde6421d2743b Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Jun 2013 22:47:22 +0000 Subject: Revise INST_EXPAND_STKTOP so that it no longer makes use of its operand. All the information required to do a proper expansion of the exec stack to support expanded command invocation is already present. The operand doesn't provide any essential information. By ignoring it, we eliminate the risk that the compiler might fill in the operand with a bad stack depth estimate value. INST_EXPAND_STKTOP doesn't need an operand, but in order to support loading of existing bytecodes we cannot change it now. There's also no need to change what the compiler tries to place in the operand, though changing it to always be zeros would be acceptable now. --- generic/tclExecute.c | 37 +++++++++++++++++++++++-------------- 1 file changed, 23 insertions(+), 14 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f5737b5..98f1ed8 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -202,6 +202,9 @@ typedef struct TEBCdata { #define PUSH_TAUX_OBJ(objPtr) \ do { \ + if (auxObjList) { \ + objPtr->length += auxObjList->length; \ + } \ objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \ auxObjList = objPtr; \ } while (0) @@ -2717,6 +2720,7 @@ TEBCresume( TclNewObj(objPtr); objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; + objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); NEXT_INST_F(1, 0, 0); @@ -2761,22 +2765,27 @@ TEBCresume( * stack depth, as seen by the compiler. */ - length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1)); - DECACHE_STACK_INFO(); - moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - - (Tcl_Obj **) TD; - if (moved) { - /* - * Change the global data to point to the new stack: move the - * TEBCdataPtr TD, recompute the position of every other - * stack-allocated parameter, update the stack pointers. - */ + auxObjList->length += objc - 1; + if ((objc > 1) && (auxObjList-length > 0)) { + length = auxObjList->length /* Total expansion room we need */ + + codePtr->maxStackDepth /* Beyond the original max */ + - CURR_DEPTH; /* Relative to where we are */ + DECACHE_STACK_INFO(); + moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) + - (Tcl_Obj **) TD; + if (moved) { + /* + * Change the global data to point to the new stack: move the + * TEBCdataPtr TD, recompute the position of every other + * stack-allocated parameter, update the stack pointers. + */ - esPtr = iPtr->execEnvPtr->execStackPtr; - TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); + esPtr = iPtr->execEnvPtr->execStackPtr; + TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); - catchTop += moved; - tosPtr += moved; + catchTop += moved; + tosPtr += moved; + } } /* -- cgit v0.12 From c90aa17e6ef729c6cab8a8f6a1ca988c9c3d4b62 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jun 2013 10:24:52 +0000 Subject: Silence various warnings when doing a 64-bit build with MSVC: Those warnings can only _really_ be fixed in "novem" (so, don't silence them there) --- win/tclWinPort.h | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 987d45b..b545a09 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -350,9 +350,9 @@ typedef DWORD_PTR * PDWORD_PTR; #if defined(_MSC_VER) || defined(__MINGW32__) # define environ _environ -# if defined(_MSC_VER) && (_MSC_VER < 1600) +# if defined(_MSC_VER) && (_MSC_VER < 1600) # define hypot _hypot -# endif +# endif # define exception _exception # undef EDEADLOCK # if defined(__MINGW32__) && !defined(__MSVCRT__) @@ -381,8 +381,10 @@ typedef DWORD_PTR * PDWORD_PTR; * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ -#if _MSC_VER >= 1400 -#pragma warning(disable:4996) +#if defined(_MSC_VER) && (_MSC_VER >= 1400) +# pragma warning(disable:4244) +# pragma warning(disable:4267) +# pragma warning(disable:4996) #endif -- cgit v0.12 From cd31de89b083f0dc02aee63895b89d45e6c1ffb9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jun 2013 12:24:23 +0000 Subject: Workaround for mingw-w64 (AMD64-only) bug: It appears that zdll.lib (as produced by Microsoft tools) doesn't import the zlib symbols correctly, so use "libz.dll.a" produced with mingw-w64 tools in stead. --- compat/zlib/win64/libz.dll.a | Bin 0 -> 46874 bytes win/Makefile.in | 2 +- win/configure | 12 +++++++++++- win/configure.in | 6 +++++- 4 files changed, 17 insertions(+), 3 deletions(-) create mode 100644 compat/zlib/win64/libz.dll.a diff --git a/compat/zlib/win64/libz.dll.a b/compat/zlib/win64/libz.dll.a new file mode 100644 index 0000000..a3ae403 Binary files /dev/null and b/compat/zlib/win64/libz.dll.a differ diff --git a/win/Makefile.in b/win/Makefile.in index 18993fe..47f3fdd 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -458,7 +458,7 @@ ${TEST_DLL_FILE}: ${TCLTEST_OBJS} ${TCL_STUB_LIB_FILE} # use pre-built zlib1.dll ${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} - @if test "@ZLIB_LIBS@set" == "${ZLIB_DIR}/win64/zdll.libset" ; then \ + @if test "@ZLIB_LIBS@set" != "${ZLIB_DIR}/win32/zdll.libset" ; then \ $(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ else \ $(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ diff --git a/win/configure b/win/configure index bad344c..fc453f8 100755 --- a/win/configure +++ b/win/configure @@ -4362,7 +4362,17 @@ if test "$tcl_ok" = "yes"; then if test "$do64bit" = "yes"; then - ZLIB_LIBS=\${ZLIB_DIR}/win64/zdll.lib + if test "$GCC" == "yes"; then + + ZLIB_LIBS=\${ZLIB_DIR}/win64/libz.dll.a + + +else + + ZLIB_LIBS=\${ZLIB_DIR}/win64/zdll.lib + + +fi else diff --git a/win/configure.in b/win/configure.in index 574fce2..373cfcc 100644 --- a/win/configure.in +++ b/win/configure.in @@ -129,7 +129,11 @@ AS_IF([test "${enable_shared+set}" = "set"], [ AS_IF([test "$tcl_ok" = "yes"], [ AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) AS_IF([test "$do64bit" = "yes"], [ - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win64/zdll.lib]) + AS_IF([test "$GCC" == "yes"],[ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win64/libz.dll.a]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win64/zdll.lib]) + ]) ], [ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR}/win32/zdll.lib]) ]) -- cgit v0.12 From b59537759a964c286781a6e052893f1f55e7c7b1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jun 2013 19:36:49 +0000 Subject: Fix env.test when running mingw-w64 (AMD64 build) test-suite on wine64 --- tests/env.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/env.test b/tests/env.test index c42e49d..ee13b7f 100644 --- a/tests/env.test +++ b/tests/env.test @@ -86,7 +86,7 @@ set printenvScript [makeFile { SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles + CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 } { lrem names $name } @@ -118,7 +118,7 @@ foreach name [array names env] { SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles + CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432 }} { unset env($name) } -- cgit v0.12 From 232d48bde8d33fd790e47e94cf9f239db3099505 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Jun 2013 07:13:09 +0000 Subject: Fix some gcc warnings which become visible with -Wextra --- generic/tclIOCmd.c | 34 +++++++++++++++++----------------- generic/tclThreadTest.c | 22 +++++++++++----------- 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 21dcd71..2958bc8 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1823,24 +1823,24 @@ TclInitChanCmd( * function at the moment. */ static const EnsembleImplMap initMap[] = { - {"blocked", Tcl_FblockedObjCmd}, - {"close", Tcl_CloseObjCmd}, - {"copy", Tcl_FcopyObjCmd}, - {"create", TclChanCreateObjCmd}, /* TIP #219 */ - {"eof", Tcl_EofObjCmd}, - {"event", Tcl_FileEventObjCmd}, - {"flush", Tcl_FlushObjCmd}, - {"gets", Tcl_GetsObjCmd}, - {"pending", ChanPendingObjCmd}, /* TIP #287 */ - {"postevent", TclChanPostEventObjCmd}, /* TIP #219 */ - {"puts", Tcl_PutsObjCmd}, - {"read", Tcl_ReadObjCmd}, - {"seek", Tcl_SeekObjCmd}, - {"tell", Tcl_TellObjCmd}, - {"truncate", ChanTruncateObjCmd}, /* TIP #208 */ - {NULL} + {"blocked", Tcl_FblockedObjCmd, NULL}, + {"close", Tcl_CloseObjCmd, NULL}, + {"copy", Tcl_FcopyObjCmd, NULL}, + {"create", TclChanCreateObjCmd, NULL}, /* TIP #219 */ + {"eof", Tcl_EofObjCmd, NULL}, + {"event", Tcl_FileEventObjCmd, NULL}, + {"flush", Tcl_FlushObjCmd, NULL}, + {"gets", Tcl_GetsObjCmd, NULL}, + {"pending", ChanPendingObjCmd, NULL}, /* TIP #287 */ + {"postevent", TclChanPostEventObjCmd, NULL}, /* TIP #219 */ + {"puts", Tcl_PutsObjCmd, NULL}, + {"read", Tcl_ReadObjCmd, NULL}, + {"seek", Tcl_SeekObjCmd, NULL}, + {"tell", Tcl_TellObjCmd, NULL}, + {"truncate", ChanTruncateObjCmd, NULL}, /* TIP #208 */ + {NULL,NULL, NULL} }; - static const char *extras[] = { + static const char *const extras[] = { "configure", "::fconfigure", "names", "::file channels", NULL diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index d032cc6..f899779 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -292,7 +292,7 @@ Tcl_ThreadObjCmd( return TCL_OK; case THREAD_ID: if (objc == 2) { - Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread()); + Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t) Tcl_GetCurrentThread()); Tcl_SetObjResult(interp, idObj); return TCL_OK; @@ -301,24 +301,24 @@ Tcl_ThreadObjCmd( return TCL_ERROR; } case THREAD_JOIN: { - long id; + Tcl_WideInt id; int result, status; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "id"); return TCL_ERROR; } - if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) { return TCL_ERROR; } - result = Tcl_JoinThread ((Tcl_ThreadId) id, &status); + result = Tcl_JoinThread ((Tcl_ThreadId)(size_t)id, &status); if (result == TCL_OK) { Tcl_SetIntObj (Tcl_GetObjResult (interp), status); } else { char buf [20]; - sprintf(buf, "%ld", id); + sprintf(buf, "%" TCL_LL_MODIFIER "d", id); Tcl_AppendResult(interp, "cannot join thread ", buf, NULL); } return result; @@ -330,7 +330,7 @@ Tcl_ThreadObjCmd( } return TclThreadList(interp); case THREAD_SEND: { - long id; + Tcl_WideInt id; const char *script; int wait, arg; @@ -349,12 +349,12 @@ Tcl_ThreadObjCmd( wait = 1; arg = 2; } - if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) { return TCL_ERROR; } arg++; script = Tcl_GetString(objv[arg]); - return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait); + return TclThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait); } case THREAD_ERRORPROC: { /* @@ -434,7 +434,7 @@ TclCreateThread( Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL); Tcl_MutexUnlock(&threadMutex); Tcl_ConditionFinalize(&ctrl.condWait); - Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)(size_t)id)); return TCL_OK; } @@ -560,7 +560,7 @@ ThreadErrorProc( const char *errorInfo, *argv[3]; char *script; char buf[TCL_DOUBLE_SPACE+1]; - sprintf(buf, "%ld", (long) Tcl_GetCurrentThread()); + sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (errorProcString == NULL) { @@ -677,7 +677,7 @@ TclThreadList( Tcl_MutexLock(&threadMutex); for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) { Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewLongObj((long) tsdPtr->threadId)); + Tcl_NewWideIntObj((Tcl_WideInt)(size_t)tsdPtr->threadId)); } Tcl_MutexUnlock(&threadMutex); Tcl_SetObjResult(interp, listPtr); -- cgit v0.12 From c3bb908ec5427846f355b333087a3e4c19e71d4e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Jun 2013 10:11:08 +0000 Subject: Don't use deprecated stricmp/strnicmp any more, but underscored variant for non-GNU compilers. --- win/tclWinPort.h | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index b545a09..ec9e867 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -64,11 +64,9 @@ typedef DWORD_PTR * PDWORD_PTR; #include #include -#ifndef strncasecmp -# define strncasecmp strnicmp -#endif -#ifndef strcasecmp -# define strcasecmp stricmp +#ifndef __GNUC__ +# define strncasecmp _strnicmp +# define strcasecmp _stricmp #endif /* -- cgit v0.12 From 68292a6506ecddc2460b6f47f7589f8ad66a4858 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 16 Jun 2013 20:32:50 +0000 Subject: split off TclInitStubTable() as separate function - which does the actual stub table initialization - previously part of Tcl_InitStubs(). --- generic/tclInt.h | 8 ++++++ generic/tclStubLib.c | 27 +++---------------- generic/tclStubLibTbl.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 6 ++++- win/Makefile.in | 4 +++ win/makefile.bc | 4 +++ win/makefile.vc | 4 +++ win/tcl.dsp | 4 +++ 8 files changed, 101 insertions(+), 25 deletions(-) create mode 100644 generic/tclStubLibTbl.c diff --git a/generic/tclInt.h b/generic/tclInt.h index e60b627..1cf0337 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3831,6 +3831,14 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +/* Used internally in stub library. */ +typedef struct { + char version[16]; + ClientData data; +} TclStubInfoType; + +MODULE_SCOPE const char *TclInitStubTable(const char *version); + /* * Functions defined in generic/tclVar.c and currenttly exported only for use * by the bytecode compiler and engine. Some of these could later be placed in diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 859cbf9..e617515 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -13,16 +13,6 @@ #include "tclInt.h" -MODULE_SCOPE const TclStubs *tclStubsPtr; -MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr; -MODULE_SCOPE const TclIntStubs *tclIntStubsPtr; -MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr; - -const TclStubs *tclStubsPtr = NULL; -const TclPlatStubs *tclPlatStubsPtr = NULL; -const TclIntStubs *tclIntStubsPtr = NULL; -const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; - /* * Use our own isDigit to avoid linking to libc on windows */ @@ -58,7 +48,7 @@ Tcl_InitStubs( { Interp *iPtr = (Interp *) interp; const char *actualVersion = NULL; - ClientData pkgData = NULL; + TclStubInfoType stub; const TclStubs *stubsPtr = iPtr->stubTable; /* @@ -73,7 +63,7 @@ Tcl_InitStubs( return NULL; } - actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &stub.data); if (actualVersion == NULL) { return NULL; } @@ -103,18 +93,7 @@ Tcl_InitStubs( } } } - tclStubsPtr = (TclStubs *)pkgData; - - if (tclStubsPtr->hooks) { - tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; - tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; - tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; - } else { - tclPlatStubsPtr = NULL; - tclIntStubsPtr = NULL; - tclIntPlatStubsPtr = NULL; - } - + TclInitStubTable(stub.version); return actualVersion; } diff --git a/generic/tclStubLibTbl.c b/generic/tclStubLibTbl.c new file mode 100644 index 0000000..0ed057f --- /dev/null +++ b/generic/tclStubLibTbl.c @@ -0,0 +1,69 @@ +/* + * tclStubLibTbl.c -- + * + * Stub object that will be statically linked into extensions that want + * to access Tcl. + * + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1998 Paul Duffin. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" + +MODULE_SCOPE const TclStubs *tclStubsPtr; +MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr; +MODULE_SCOPE const TclIntStubs *tclIntStubsPtr; +MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr; + +const TclStubs *tclStubsPtr = NULL; +const TclPlatStubs *tclPlatStubsPtr = NULL; +const TclIntStubs *tclIntStubsPtr = NULL; +const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; + + +/* + *---------------------------------------------------------------------- + * + * TclInitStubTable -- + * + * Initialize the stub table, using the structure pointed at + * by the "version" argument. + * + * Results: + * Outputs the value of the "version" argument. + * + * Side effects: + * Sets the stub table pointers. + * + *---------------------------------------------------------------------- + */ +MODULE_SCOPE const char * +TclInitStubTable( + const char *version) /* points to the version field of a + TclStubInfoType structure variable. */ +{ + const TclStubInfoType *ptr = (const TclStubInfoType *) version; + tclStubsPtr = (const TclStubs *) ptr->data; + + if (tclStubsPtr->hooks) { + tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; + tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; + tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; + } else { + tclPlatStubsPtr = NULL; + tclIntStubsPtr = NULL; + tclIntPlatStubsPtr = NULL; + } + return version; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/Makefile.in b/unix/Makefile.in index 3e4a6f6..94a5473 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,7 +335,7 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o -STUB_LIB_OBJS = tclStubLib.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} +STUB_LIB_OBJS = tclStubLib.o tclStubLibTbl.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ @@ -470,6 +470,7 @@ OO_SRCS = \ STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ + $(GENERIC_DIR)/tclStubLibTbl.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c @@ -1685,6 +1686,9 @@ Zzutil.o: $(ZLIB_DIR)/zutil.c tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c +tclStubLibTbl.o: $(GENERIC_DIR)/tclStubLibTbl.c + $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLibTbl.c + tclTomMathStubLib.o: $(GENERIC_DIR)/tclTomMathStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclTomMathStubLib.c diff --git a/win/Makefile.in b/win/Makefile.in index 47f3fdd..d7b25b7 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -385,6 +385,7 @@ REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ + tclStubLibTbl.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ tclOOStubLib.$(OBJEXT) @@ -515,6 +516,9 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c tclStubLib.${OBJEXT}: tclStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) +tclStubLibTbl.${OBJEXT}: tclStubLibTbl.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) + tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) diff --git a/win/makefile.bc b/win/makefile.bc index 0b17cea..2726dad 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -279,6 +279,7 @@ TCLOBJS = \ TCLSTUBOBJS = \ $(TMPDIR)\tclStubLib.obj \ + $(TMPDIR)\tclStubLibTbl.obj \ $(TMPDIR)\tclTomMathStubLib.obj \ $(TMPDIR)\tclOOStubLib.obj @@ -528,6 +529,9 @@ $(TMPDIR)\tclWinDde.obj : $(WINDIR)\tclWinDde.c $(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? +$(TMPDIR)\tclStubLibTbl.obj : $(GENERICDIR)\tclStubLibTbl.c + $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? + $(TMPDIR)\tclTomMathStubLib.obj : $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? diff --git a/win/makefile.vc b/win/makefile.vc index cddb253..c24534a 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -450,6 +450,7 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ + $(TMP_DIR)\tclStubLibTbl.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj @@ -979,6 +980,9 @@ $(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)\tclStubLibTbl.obj: $(GENERICDIR)\tclStubLibTbl.c + $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? + $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? diff --git a/win/tcl.dsp b/win/tcl.dsp index 57ec6bf..2708051 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1300,6 +1300,10 @@ SOURCE=..\generic\tclStubLib.c # End Source File # Begin Source File +SOURCE=..\generic\tclStubLibTbl.c +# End Source File +# Begin Source File + SOURCE=..\generic\tclOOStubLib.c # End Source File # Begin Source File -- cgit v0.12 From be5d1b00c4af601c562154ca455e2c0e9801d8c1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 16 Jun 2013 20:48:57 +0000 Subject: link tclsh with stub library, just like xttest and tcltest, in order to allow additional static stub-enabled libraries to be linked with it. --- unix/Makefile.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 94a5473..5295a45 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -633,9 +633,9 @@ tclLibObjs: # This targets actually build the objects needed for the lib in the above case objs: ${OBJS} -${TCL_EXE}: ${TCLSH_OBJS} ${TCL_LIB_FILE} +${TCL_EXE}: ${TCLSH_OBJS} ${TCL_LIB_FILE} ${TCL_STUB_LIB_FILE} ${CC} ${CFLAGS} ${LDFLAGS} ${TCLSH_OBJS} \ - @TCL_BUILD_LIB_SPEC@ ${LIBS} @EXTRA_TCLSH_LIBS@ \ + @TCL_BUILD_LIB_SPEC@ ${TCL_STUB_LIB_FILE} ${LIBS} @EXTRA_TCLSH_LIBS@ \ ${CC_SEARCH_FLAGS} -o ${TCL_EXE} # Must be empty so it doesn't conflict with rule for ${TCL_EXE} above -- cgit v0.12 From 259d5037ca4b4dc37c6e6b01d6d2ffee9c249d52 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Jun 2013 04:41:57 +0000 Subject: On 32-bit platforms, 12 characters for version is enough, on 64-bit platforms it will be aligned to 16 characters anyway. --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 1cf0337..2d3a248 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3833,7 +3833,7 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, /* Used internally in stub library. */ typedef struct { - char version[16]; + char version[12]; ClientData data; } TclStubInfoType; -- cgit v0.12 From f6678bdedc2a7668eb984f7e375886da59a63888 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Jun 2013 04:52:01 +0000 Subject: Fix [a876646efe]: re_expr character class [:cntrl:] should contain \u0000 - \u001f --- ChangeLog | 5 +++++ generic/regc_locale.c | 5 +++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9d5e542..54c3b99 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-06-17 Jan Nijtmans + + * generic/regc_locale.c: Bug [a876646efe]: re_expr character class + [:cntrl:] should contain \u0000 - \u001f + 2013-06-03 Miguel Sofer * generic/tclExecute.c: fix for perf bug detected by Kieran diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 40791f4..dd1c01c 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -259,8 +259,9 @@ static const chr alphaCharTable[] = { */ static const crange controlRangeTable[] = { - {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, {0x202a, 0x202e}, - {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb} + {0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, + {0x202a, 0x202e}, {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, + {0xfff9, 0xfffb} #if TCL_UTF_MAX > 4 ,{0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, {0x100000, 0x10fffd} #endif -- cgit v0.12 From 70024494041b53923a32939fa834efcfd2f1f888 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Jun 2013 13:23:29 +0000 Subject: Use more portable TclIsSpaceProc() in stead of isspace(). Make sure that "string is space \u180e" continues to return 1 for whatever unicode version. --- generic/tclCmdAH.c | 7 +++---- generic/tclDate.c | 2 +- generic/tclUtf.c | 4 +++- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 44f08a3..7f0df83 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -130,8 +130,7 @@ Tcl_CaseObjCmd( for (i = 0; i < caseObjc; i += 2) { int patObjc, j; const char **patObjv; - char *pat; - unsigned char *p; + char *pat, *p; if (i == (caseObjc - 1)) { Tcl_ResetResult(interp); @@ -145,8 +144,8 @@ Tcl_CaseObjCmd( */ pat = TclGetString(caseObjv[i]); - for (p = (unsigned char *) pat; *p != '\0'; p++) { - if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ + for (p = pat; *p != '\0'; p++) { + if (TclIsSpaceProc(*p) || (*p == '\\')) { break; } } diff --git a/generic/tclDate.c b/generic/tclDate.c index 59da2ea..0bda22f 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2690,7 +2690,7 @@ TclDatelex( location->first_column = yyInput - info->dateStart; for ( ; ; ) { - while (isspace(UCHAR(*yyInput))) { + while (TclIsSpaceProc(*yyInput)) { yyInput++; } diff --git a/generic/tclUtf.c b/generic/tclUtf.c index f3d1758..a122685 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1554,7 +1554,9 @@ Tcl_UniCharIsSpace( */ if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { - return isspace(UCHAR(ch)); /* INTL: ISO space */ + return TclIsSpaceProc(ch); + } else if ((Tcl_UniChar) ch == 0x180e) { + return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); } -- cgit v0.12 From 5298476c8a9dce4f5b1e2519220df640ba3c7046 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 17 Jun 2013 17:03:18 +0000 Subject: Updates to redirect bug reports to the new tracker location. --- README | 29 ++++++++++++++--------------- macosx/README | 4 ++-- unix/README | 5 +++-- win/README | 4 ++-- 4 files changed, 21 insertions(+), 21 deletions(-) diff --git a/README b/README index 8cc9b9a..0b3cf05 100644 --- a/README +++ b/README @@ -1,8 +1,7 @@ README: Tcl This is the Tcl 8.5.14 source distribution. - http://tcl.sourceforge.net/ - You can get any source release of Tcl from the file distributions - link at the above URL. + http://sourceforge.net/projects/tcl/files/Tcl/ + You can get any source release of Tcl from the URL above. Contents -------- @@ -27,9 +26,14 @@ Tcl can also be used for a variety of web-related tasks and for creating powerful command languages for applications. Tcl is maintained, enhanced, and distributed freely by the Tcl community. -The home for Tcl/Tk releases and bug/patch database is on SourceForge: +Source code development and tracking of bug reports and feature requests +takes place at: - http://tcl.sourceforge.net/ + http://core.tcl.tk/ + +Tcl/Tk release and mailing list services are hosted by SourceForge: + + http://sourceforge.net/projects/tcl/ with the Tcl Developer Xchange hosted at: @@ -49,7 +53,7 @@ The home page for this release, including new features, is Detailed release notes can be found at the file distributions page by clicking on the relevant version. - http://sourceforge.net/projects/tcl/files/ + http://sourceforge.net/projects/tcl/files/Tcl/ Information about Tcl itself can be found at http://www.tcl.tk/about/ @@ -146,18 +150,13 @@ and go to the Mailing Lists page. ------------------------ We are very interested in receiving bug reports, patches, and suggestions -for improvements. We prefer that you send this information to us via the -bug form at SourceForge, rather than emailing us directly. The bug -database is at: - - http://tcl.sourceforge.net/ +for improvements. We prefer that you send this information to us as +tickets entered into our tracker at: -The bug form was designed to give uniform structure to bug reports as -well as to solicit enough information to minimize followup questions. + http://core.tcl.tk/tcl/reportlist We will log and follow-up on each bug, although we cannot promise a -specific turn-around time. Enhancements, reported via the Feature -Requests form at the same web site, may take longer and may not happen +specific turn-around time. Enhancements may take longer and may not happen at all unless there is widespread support for them (we're trying to slow the rate at which Tcl/Tk turns into a kitchen sink). It's very difficult to make incompatible changes to Tcl/Tk at this point, due to diff --git a/macosx/README b/macosx/README index 80bed14..06e797e 100644 --- a/macosx/README +++ b/macosx/README @@ -20,8 +20,8 @@ before asking on the list, many questions have already been answered). http://wiki.tcl.tk/_/ref?N=3753 http://wiki.tcl.tk/_/ref?N=8361 -- Please report bugs with Tcl or Tk on Mac OS X to the sourceforge bug trackers: - http://tcl.sourceforge.net/ +- Please report bugs with Tcl on Mac OS X to the tracker: + http://core.tcl.tk/tcl/reportlist 2. Using Tcl on Mac OS X ------------------------ diff --git a/unix/README b/unix/README index 87b151a..d8f1090 100644 --- a/unix/README +++ b/unix/README @@ -163,6 +163,7 @@ you'll see a much more substantial printout for each error. See the README file in the "tests" directory for more information on the test suite. Note: don't run the tests as superuser: this will cause several of them to fail. If a test is failing consistently, please send us a bug report with as much -detail as you can manage. Please use the online database at - http://tcl.sourceforge.net/ +detail as you can manage to our tracker: + + http://core.tcl.tk/tcl/reportlist diff --git a/win/README b/win/README index 1cb04f3..8288e3d 100644 --- a/win/README +++ b/win/README @@ -91,9 +91,9 @@ Note: Tcl no longer provides support for Win32s. This distribution contains an extensive test suite for Tcl. Some of the tests are timing dependent and will fail from time to time. If a test is failing consistently, please send us a bug report with as much detail as -you can manage. Please use the online database at +you can manage to our tracker: - http://tcl.sourceforge.net/ + http://core.tcl.tk/tcl/reportlist In order to run the test suite, you build the "test" target using the appropriate makefile for your compiler. -- cgit v0.12 From 37cc146f7519bf3d0dda8573a541121f0465b035 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Jun 2013 17:03:49 +0000 Subject: Fix [42b8083613] --- win/tclWinFile.c | 4 ++++ win/tclWinPort.h | 12 ++++-------- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1d9f93a..31fa603 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -18,6 +18,10 @@ #include #include /* For TclpGetUserHome(). */ +#if defined(_MSC_VER) +# define vsnprintf _vsnprintf +#endif + /* * The number of 100-ns intervals between the Windows system epoch (1601-01-01 * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01). diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 026cf9e..61f149b 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -466,16 +466,12 @@ typedef DWORD_PTR * PDWORD_PTR; * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ -#if defined(_MSC_VER) -# if _MSC_VER >= 1400 -# pragma warning(disable:4244) -# pragma warning(disable:4267) -# pragma warning(disable:4996) -# endif -# define vsnprintf _vsnprintf +#if defined(_MSC_VER) && (_MSC_VER >= 1400) +# pragma warning(disable:4244) +# pragma warning(disable:4267) +# pragma warning(disable:4996) #endif - /* *--------------------------------------------------------------------------- * The following macros and declarations represent the interface between -- cgit v0.12 From c694b80895cefb1f73e090593b507dfa7f6a213e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Jun 2013 07:00:04 +0000 Subject: Better place to put vsnprintf switch, so it is usable by all *.c files. Fix comment on _ANSI_ARGS_ which is no longer true since 8.6. --- generic/tclInt.h | 7 +++++-- win/tclWinFile.c | 4 ---- win/tclWinInt.h | 6 ------ 3 files changed, 5 insertions(+), 12 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 2d3a248..3432b37 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -30,8 +30,7 @@ * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but * greater modularity. The order of the three groups of #includes is - * important. For example, stdio.h is needed by tcl.h, and the _ANSI_ARGS_ - * declaration in tcl.h is needed by stdlib.h in some configurations. + * important. For example, stdio.h is needed by tcl.h. */ #include "tclPort.h" @@ -119,6 +118,10 @@ typedef int ptrdiff_t; # endif #endif +#if defined(_WIN32) && defined(_MSC_VER) +# define vsnprintf _vsnprintf +#endif + /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 31fa603..1d9f93a 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -18,10 +18,6 @@ #include #include /* For TclpGetUserHome(). */ -#if defined(_MSC_VER) -# define vsnprintf _vsnprintf -#endif - /* * The number of 100-ns intervals between the Windows system epoch (1601-01-01 * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01). diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 22ad8e9..882b811 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -33,12 +33,6 @@ # define TCL_I_MODIFIER "" #endif -#ifdef _WIN64 -# define TCL_I_MODIFIER "I" -#else -# define TCL_I_MODIFIER "" -#endif - /* * Declarations of functions that are not accessible by way of the * stubs table. -- cgit v0.12 From 914227b03938ff6da7a4b35ef2e9a2b495df3ba0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Jun 2013 07:43:59 +0000 Subject: Fix uniClass tool which was the real cause for [a876646efe], and add test-case for it. --- tests/utf.test | 4 ++-- tools/uniClass.tcl | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/utf.test b/tests/utf.test index ad1e7b8..35c5f73 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -322,8 +322,8 @@ test utf-21.11 {TclUniCharIsControl} { string is control \u00ad } {1} test utf-21.12 {unicode control char in regc_locale.c} { - # [Bug 3464428] - regexp {^[[:cntrl:]]$} \u00ad + # [Bug 3464428], [Bug a876646efe] + regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad } {1} test utf-22.1 {TclUniCharIsWordChar} { diff --git a/tools/uniClass.tcl b/tools/uniClass.tcl index 32b40e9..9b4819d 100644 --- a/tools/uniClass.tcl +++ b/tools/uniClass.tcl @@ -72,7 +72,7 @@ proc genTable {type} { if {$i == ($last + 1)} { set last $i } else { - if {$first > 0} { + if {$first >= 0} { emitRange $first $last } set first $i -- cgit v0.12 From c605707c6bdc1d617272e87d0d7cb15b11a5d41c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Jun 2013 10:33:33 +0000 Subject: Fix [3611974]: InitSubsystems multiple thread issue --- ChangeLog | 4 ++++ generic/tclEvent.c | 13 ++++--------- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index 54c3b99..247dca4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2013-06-18 Jan Nijtmans + + * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread issue. + 2013-06-17 Jan Nijtmans * generic/regc_locale.c: Bug [a876646efe]: re_expr character class diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 7daa7bb..d98685a 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -949,14 +949,8 @@ TclInitSubsystems(void) TclpInitLock(); if (subsystemsInitialized == 0) { - /* - * Have to set this bit here to avoid deadlock with the routines - * below us that call into TclInitSubsystems. - */ - - subsystemsInitialized = 1; - /* + /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. @@ -974,12 +968,13 @@ TclInitSubsystems(void) TclpInitPlatform(); /* Creates signal handler(s) */ TclInitDoubleConversion(); /* Initializes constants for * converting to/from double. */ - TclInitObjSubsystem(); /* Register obj types, create + TclInitObjSubsystem(); /* Register obj types, create * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ TclpSetInterfaces(); - TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ + TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ + subsystemsInitialized = 1; } TclpInitUnlock(); } -- cgit v0.12 From 4d100dc21f1811c0bfd773f234f59b35eb3be93a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Jun 2013 13:59:30 +0000 Subject: Update Unicode tables to latest 6.3 beta version --- generic/regc_locale.c | 29 ++++++++++------------------- 1 file changed, 10 insertions(+), 19 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 5d6c916..0006635 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -191,10 +191,6 @@ static const crange alphaRangeTable[] = { {0xaadb, 0xaadd}, {0xaae0, 0xaaea}, {0xaaf2, 0xaaf4}, {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, {0xab28, 0xab2e}, {0xabc0, 0xabe2}, {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, - {0xdc02, 0xdc3e}, {0xdc40, 0xdc7e}, {0xdc80, 0xdcbe}, {0xdcc0, 0xdcfe}, - {0xdd02, 0xdd3e}, {0xdd40, 0xdd7e}, {0xdd80, 0xddbe}, {0xddc0, 0xddfe}, - {0xde02, 0xde3e}, {0xde40, 0xde7e}, {0xde80, 0xdebe}, {0xdec0, 0xdefe}, - {0xdf02, 0xdf3e}, {0xdf40, 0xdf7e}, {0xdf80, 0xdfbe}, {0xdfc0, 0xdffe}, {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1f, 0xfb28}, {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfd3d}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, @@ -246,8 +242,7 @@ static const chr alphaCharTable[] = { 0x207f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x214e, 0x2183, 0x2184, 0x2cf2, 0x2cf3, 0x2d27, 0x2d2d, 0x2d6f, 0x2e2f, 0x3005, 0x3006, 0x303b, 0x303c, 0xa62a, 0xa62b, 0xa8fb, 0xa9cf, 0xaa7a, 0xaab1, 0xaab5, - 0xaab6, 0xaac0, 0xaac2, 0xdc00, 0xdd00, 0xde00, 0xdf00, 0xfb1d, 0xfb3e, - 0xfb40, 0xfb41, 0xfb43, 0xfb44 + 0xaab6, 0xaac0, 0xaac2, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44 #if TCL_UTF_MAX > 4 ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x109be, 0x109bf, 0x10a00, 0x16f50, 0x1b000, 0x1b001, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, @@ -321,12 +316,13 @@ static const crange punctRangeTable[] = { {0x17d8, 0x17da}, {0x1800, 0x180a}, {0x1aa0, 0x1aa6}, {0x1aa8, 0x1aad}, {0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7}, {0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e}, - {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, {0x29d8, 0x29db}, - {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, {0x3001, 0x3003}, - {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, {0xa6f2, 0xa6f7}, - {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, {0xaa5c, 0xaa5f}, - {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03}, - {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff5f, 0xff65} + {0x2308, 0x230b}, {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, + {0x29d8, 0x29db}, {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, + {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, + {0xa6f2, 0xa6f7}, {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, + {0xaa5c, 0xaa5f}, {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, + {0xff01, 0xff03}, {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, + {0xff5f, 0xff65} #if TCL_UTF_MAX > 4 ,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10b39, 0x10b3f}, {0x11047, 0x1104d}, {0x110be, 0x110c1}, {0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x12470, 0x12473} @@ -642,11 +638,7 @@ static const crange graphRangeTable[] = { {0xaa40, 0xaa4d}, {0xaa50, 0xaa59}, {0xaa5c, 0xaa7b}, {0xaa80, 0xaac2}, {0xaadb, 0xaaf6}, {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, {0xab28, 0xab2e}, {0xabc0, 0xabed}, {0xabf0, 0xabf9}, - {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xdc00, 0xdc3e}, - {0xdc42, 0xdc7e}, {0xdc80, 0xdcbe}, {0xdcc0, 0xdcfe}, {0xdd00, 0xdd3e}, - {0xdd42, 0xdd7e}, {0xdd80, 0xddbe}, {0xddc0, 0xddfe}, {0xde00, 0xde3e}, - {0xde42, 0xde7e}, {0xde80, 0xdebe}, {0xdec0, 0xdefe}, {0xdf00, 0xdf3e}, - {0xdf42, 0xdf7e}, {0xdf80, 0xdfbe}, {0xdfc0, 0xdffe}, {0xf900, 0xfa6d}, + {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbc1}, {0xfbd3, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfd}, {0xfe00, 0xfe19}, {0xfe20, 0xfe26}, @@ -705,8 +697,7 @@ static const chr graphCharTable[] = { 0xe84, 0xe87, 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab, 0xec6, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x1772, 0x1773, 0x1940, 0x1f59, 0x1f5b, 0x1f5d, 0x2070, 0x2071, 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xa9de, - 0xa9df, 0xdc40, 0xdd40, 0xde40, 0xdf40, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, - 0xfb44, 0xfffc, 0xfffd + 0xa9df, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfffc, 0xfffd #if TCL_UTF_MAX > 4 ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x1093f, 0x109be, 0x109bf, 0x10a05, 0x10a06, 0x1b000, 0x1b001, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, -- cgit v0.12 From cf557ca4a54a4f8d0ca476e5326675a9ab56f7f9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Jun 2013 12:53:53 +0000 Subject: Eliminate a lot of dead code (for Windows 95/98/ME only). Eliminate all usage of TclWinSetInterfaces(), which does exactly the same as TclpSetInterfaces(), but keep exported symbol and stub entry. --- win/tclWin32Dll.c | 28 +--- win/tclWinFCmd.c | 43 ----- win/tclWinFile.c | 464 ++++++++++++++++++------------------------------------ win/tclWinInit.c | 9 +- win/tclWinPipe.c | 13 +- 5 files changed, 164 insertions(+), 393 deletions(-) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 019d76f..0d3b683 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -281,16 +281,9 @@ TclWinNoBackslash( /* *--------------------------------------------------------------------------- * - * TclWinSetInterfaces -- + * TclpSetInterfaces -- * - * A helper proc that allows the test library to change the tclWinProcs - * structure to dispatch to either the wide-character or multi-byte - * versions of the operating system calls, depending on whether Unicode - * is the system encoding. - * - * As well as this, we can also try to load in some additional procs - * which may/may not be present depending on the current Windows version - * (e.g. Win95 will not have the procs below). + * A helper proc that initializes winTCharEncoding. * * Results: * None. @@ -302,15 +295,10 @@ TclWinNoBackslash( */ void -TclWinSetInterfaces( - int wide) /* Non-zero to use wide interfaces, 0 - * otherwise. */ +TclpSetInterfaces(void) { - TclWinResetInterfaces(); - - if (wide) { - winTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); - } + TclWinResetInterfaces(); + winTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); } /* @@ -318,9 +306,7 @@ TclWinSetInterfaces( * * TclWinEncodingsCleanup -- * - * Called during finalization to free up any encodings we use. The - * tclWinProcs-> look up table is still ok to use after this call, - * provided no encoding conversion is required. + * Called during finalization to free up any encodings we use. * * We also clean up any memory allocated in our mount point map which is * used to follow certain kinds of symlinks. That code should never be @@ -363,8 +349,6 @@ TclWinEncodingsCleanup(void) * TclWinResetInterfaces -- * * Called during finalization to reset us to a safe state for reuse. - * After this call, it is best not to use the tclWinProcs-> look up table - * since it is likely to be different to what is expected. * * Results: * None. diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index ac88861..0476915 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1105,49 +1105,6 @@ DoRemoveJustDirectory( SetFileAttributes(nativePath, attr | FILE_ATTRIBUTE_READONLY); } - - /* - * Windows 95 reports removing a non-empty directory as - * EACCES, not EEXIST. If the directory is not empty, change errno - * so caller knows what's going on. - */ - - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) { - const char *path, *find; - HANDLE handle; - WIN32_FIND_DATAA data; - Tcl_DString buffer; - int len; - - path = (const char *) nativePath; - - Tcl_DStringInit(&buffer); - len = strlen(path); - find = Tcl_DStringAppend(&buffer, path, len); - if ((len > 0) && (find[len - 1] != '\\')) { - TclDStringAppendLiteral(&buffer, "\\"); - } - find = TclDStringAppendLiteral(&buffer, "*.*"); - handle = FindFirstFileA(find, &data); - if (handle != INVALID_HANDLE_VALUE) { - while (1) { - if ((strcmp(data.cFileName, ".") != 0) - && (strcmp(data.cFileName, "..") != 0)) { - /* - * Found something in this directory. - */ - - Tcl_SetErrno(EEXIST); - break; - } - if (FindNextFileA(handle, &data) == FALSE) { - break; - } - } - FindClose(handle); - } - Tcl_DStringFree(&buffer); - } } } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1d9f93a..f69ad23 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -2415,373 +2415,213 @@ TclpObjNormalizePath( Tcl_DStringInit(&dsNorm); path = Tcl_GetString(pathPtr); - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) { - /* - * We're on Win95, 98 or ME. There are two assumptions in this block - * of code. First that the native (NULL) encoding is basically ascii, - * and second that symbolic links are not possible. Both of these - * assumptions appear to be true of these operating systems. - * - * FIXME: This code branch may be derelict as those are not supported - * platforms any more. - */ - - currentPathEndPosition = path + nextCheckpoint; - if (*currentPathEndPosition == '/') { - currentPathEndPosition++; - } - - while (1) { - char cur = *currentPathEndPosition; + currentPathEndPosition = path + nextCheckpoint; + if (*currentPathEndPosition == '/') { + currentPathEndPosition++; + } + while (1) { + char cur = *currentPathEndPosition; - if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) { - /* - * Reached directory separator, or end of string. - */ + if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) { + /* + * Reached directory separator, or end of string. + */ - const char *nativePath = Tcl_UtfToExternalDString(NULL, path, - currentPathEndPosition - path, &ds); + WIN32_FILE_ATTRIBUTE_DATA data; + const TCHAR *nativePath = Tcl_WinUtfToTChar(path, + currentPathEndPosition - path, &ds); + if (GetFileAttributesEx(nativePath, + GetFileExInfoStandard, &data) != TRUE) { /* - * Now we convert the tail of the current path to its 'long - * form', and append it to 'dsNorm' which holds the current - * normalized path, if the file exists. + * File doesn't exist. */ if (isDrive) { - if (GetFileAttributesA(nativePath) - == INVALID_FILE_ATTRIBUTES) { - /* - * File doesn't exist. - */ - - if (isDrive) { - int len = WinIsReserved(path); - - if (len > 0) { - /* - * Actually it does exist - COM1, etc. - */ - - int i; - - for (i=0 ; i= 'a') { - ((char *) nativePath)[i] -= ('a'-'A'); - } - } - Tcl_DStringAppend(&dsNorm, nativePath, len); - lastValidPathEnd = currentPathEndPosition; - } else if (nextCheckpoint == 0) { - /* Path starts with a drive designation - * that's not actually on the system. - * We still must normalize up past the - * first separator. [Bug 3603434] */ - currentPathEndPosition++; - } - } - Tcl_DStringFree(&ds); - break; - } - if (nativePath[0] >= 'a') { - ((char *) nativePath)[0] -= ('a' - 'A'); - } - Tcl_DStringAppend(&dsNorm, nativePath, - Tcl_DStringLength(&ds)); - } else { - char *checkDots = NULL; - - if (lastValidPathEnd[1] == '.') { - checkDots = lastValidPathEnd + 1; - while (checkDots < currentPathEndPosition) { - if (*checkDots != '.') { - checkDots = NULL; - break; - } - checkDots++; - } - } - if (checkDots != NULL) { - int dotLen = currentPathEndPosition-lastValidPathEnd; + int len = WinIsReserved(path); + if (len > 0) { /* - * Path is just dots. We shouldn't really ever see a - * path like that. However, to be nice we at least - * don't mangle the path - we just add the dots as a - * path segment and continue + * Actually it does exist - COM1, etc. */ - Tcl_DStringAppend(&dsNorm, (const char *) - (nativePath + Tcl_DStringLength(&ds)-dotLen), - dotLen); - } else { - /* - * Normal path. - */ + int i; - WIN32_FIND_DATAA fData; - HANDLE handle; + for (i=0 ; i= L'a') { + wc -= (L'a' - L'A'); + ((WCHAR *) nativePath)[i] = wc; } - - /* - * This is usually the '/' in 'c:/' at end of - * string. - */ - - TclDStringAppendLiteral(&dsNorm, "/"); - } else { - char *nativeName; - - if (fData.cFileName[0] != '\0') { - nativeName = fData.cFileName; - } else { - nativeName = fData.cAlternateFileName; - } - FindClose(handle); - TclDStringAppendLiteral(&dsNorm, "/"); - Tcl_DStringAppend(&dsNorm, nativeName, -1); } + Tcl_DStringAppend(&dsNorm, + (const char *)nativePath, + (int)(sizeof(WCHAR) * len)); + lastValidPathEnd = currentPathEndPosition; + } else if (nextCheckpoint == 0) { + /* Path starts with a drive designation + * that's not actually on the system. + * We still must normalize up past the + * first separator. [Bug 3603434] */ + currentPathEndPosition++; } } Tcl_DStringFree(&ds); - lastValidPathEnd = currentPathEndPosition; - if (cur == 0) { - break; - } - - /* - * If we get here, we've got past one directory delimiter, so - * we know it is no longer a drive. - */ - - isDrive = 0; + break; } - currentPathEndPosition++; - } - } else { - /* - * We're on WinNT (or 2000 or XP; something with an NT core). - */ - currentPathEndPosition = path + nextCheckpoint; - if (*currentPathEndPosition == '/') { - currentPathEndPosition++; - } - while (1) { - char cur = *currentPathEndPosition; + /* + * File 'nativePath' does exist if we get here. We now want to + * check if it is a symlink and otherwise continue with the + * rest of the path. + */ - if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) { - /* - * Reached directory separator, or end of string. - */ + /* + * Check for symlinks, except at last component of path (we + * don't follow final symlinks). Also a drive (C:/) for + * example, may sometimes have the reparse flag set for some + * reason I don't understand. We therefore don't perform this + * check for drives. + */ - WIN32_FILE_ATTRIBUTE_DATA data; - const TCHAR *nativePath = Tcl_WinUtfToTChar(path, - currentPathEndPosition - path, &ds); + if (cur != 0 && !isDrive && + data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){ + Tcl_Obj *to = WinReadLinkDirectory(nativePath); - if (GetFileAttributesEx(nativePath, - GetFileExInfoStandard, &data) != TRUE) { + if (to != NULL) { /* - * File doesn't exist. + * Read the reparse point ok. Now, reparse points need + * not be normalized, otherwise we could use: + * + * Tcl_GetStringFromObj(to, &pathLen); + * nextCheckpoint = pathLen; + * + * So, instead we have to start from the beginning. */ - if (isDrive) { - int len = WinIsReserved(path); - - if (len > 0) { - /* - * Actually it does exist - COM1, etc. - */ - - int i; + nextCheckpoint = 0; + Tcl_AppendToObj(to, currentPathEndPosition, -1); - for (i=0 ; i= L'a') { - wc -= (L'a' - L'A'); - ((WCHAR *) nativePath)[i] = wc; - } - } - Tcl_DStringAppend(&dsNorm, - (const char *)nativePath, - (int)(sizeof(WCHAR) * len)); - lastValidPathEnd = currentPathEndPosition; - } else if (nextCheckpoint == 0) { - /* Path starts with a drive designation - * that's not actually on the system. - * We still must normalize up past the - * first separator. [Bug 3603434] */ - currentPathEndPosition++; + for (path = Tcl_GetString(to); *path != 0; path++) { + if (*path == '\\') { + *path = '/'; } } - Tcl_DStringFree(&ds); - break; - } - - /* - * File 'nativePath' does exist if we get here. We now want to - * check if it is a symlink and otherwise continue with the - * rest of the path. - */ - - /* - * Check for symlinks, except at last component of path (we - * don't follow final symlinks). Also a drive (C:/) for - * example, may sometimes have the reparse flag set for some - * reason I don't understand. We therefore don't perform this - * check for drives. - */ + path = Tcl_GetString(to); + currentPathEndPosition = path + nextCheckpoint; + if (temp != NULL) { + Tcl_DecrRefCount(temp); + } + temp = to; - if (cur != 0 && !isDrive && - data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){ - Tcl_Obj *to = WinReadLinkDirectory(nativePath); + /* + * Reset variables so we can restart normalization. + */ - if (to != NULL) { - /* - * Read the reparse point ok. Now, reparse points need - * not be normalized, otherwise we could use: - * - * Tcl_GetStringFromObj(to, &pathLen); - * nextCheckpoint = pathLen; - * - * So, instead we have to start from the beginning. - */ + isDrive = 1; + Tcl_DStringFree(&dsNorm); + Tcl_DStringFree(&ds); + continue; + } + } - nextCheckpoint = 0; - Tcl_AppendToObj(to, currentPathEndPosition, -1); +#ifndef TclNORM_LONG_PATH + /* + * Now we convert the tail of the current path to its 'long + * form', and append it to 'dsNorm' which holds the current + * normalized path + */ - /* - * Convert link to forward slashes. - */ + if (isDrive) { + WCHAR drive = ((WCHAR *) nativePath)[0]; - for (path = Tcl_GetString(to); *path != 0; path++) { - if (*path == '\\') { - *path = '/'; - } - } - path = Tcl_GetString(to); - currentPathEndPosition = path + nextCheckpoint; - if (temp != NULL) { - Tcl_DecrRefCount(temp); + if (drive >= L'a') { + drive -= (L'a' - L'A'); + ((WCHAR *) nativePath)[0] = drive; + } + Tcl_DStringAppend(&dsNorm, (const char *)nativePath, + Tcl_DStringLength(&ds)); + } else { + char *checkDots = NULL; + + if (lastValidPathEnd[1] == '.') { + checkDots = lastValidPathEnd + 1; + while (checkDots < currentPathEndPosition) { + if (*checkDots != '.') { + checkDots = NULL; + break; } - temp = to; - - /* - * Reset variables so we can restart normalization. - */ - - isDrive = 1; - Tcl_DStringFree(&dsNorm); - Tcl_DStringFree(&ds); - continue; + checkDots++; } } + if (checkDots != NULL) { + int dotLen = currentPathEndPosition-lastValidPathEnd; -#ifndef TclNORM_LONG_PATH - /* - * Now we convert the tail of the current path to its 'long - * form', and append it to 'dsNorm' which holds the current - * normalized path - */ - - if (isDrive) { - WCHAR drive = ((WCHAR *) nativePath)[0]; + /* + * Path is just dots. We shouldn't really ever see a + * path like that. However, to be nice we at least + * don't mangle the path - we just add the dots as a + * path segment and continue. + */ - if (drive >= L'a') { - drive -= (L'a' - L'A'); - ((WCHAR *) nativePath)[0] = drive; - } - Tcl_DStringAppend(&dsNorm, (const char *)nativePath, - Tcl_DStringLength(&ds)); + Tcl_DStringAppend(&dsNorm, ((const char *)nativePath) + + Tcl_DStringLength(&ds) + - (dotLen * sizeof(TCHAR)), + (int)(dotLen * sizeof(TCHAR))); } else { - char *checkDots = NULL; - - if (lastValidPathEnd[1] == '.') { - checkDots = lastValidPathEnd + 1; - while (checkDots < currentPathEndPosition) { - if (*checkDots != '.') { - checkDots = NULL; - break; - } - checkDots++; - } - } - if (checkDots != NULL) { - int dotLen = currentPathEndPosition-lastValidPathEnd; + /* + * Normal path. + */ - /* - * Path is just dots. We shouldn't really ever see a - * path like that. However, to be nice we at least - * don't mangle the path - we just add the dots as a - * path segment and continue. - */ + WIN32_FIND_DATAW fData; + HANDLE handle; - Tcl_DStringAppend(&dsNorm, ((const char *)nativePath) - + Tcl_DStringLength(&ds) - - (dotLen * sizeof(TCHAR)), - (int)(dotLen * sizeof(TCHAR))); - } else { + handle = FindFirstFileW((WCHAR *) nativePath, &fData); + if (handle == INVALID_HANDLE_VALUE) { /* - * Normal path. + * This is usually the '/' in 'c:/' at end of + * string. */ - WIN32_FIND_DATAW fData; - HANDLE handle; - - handle = FindFirstFileW((WCHAR *) nativePath, &fData); - if (handle == INVALID_HANDLE_VALUE) { - /* - * This is usually the '/' in 'c:/' at end of - * string. - */ + Tcl_DStringAppend(&dsNorm, (const char *) L"/", + sizeof(WCHAR)); + } else { + WCHAR *nativeName; - Tcl_DStringAppend(&dsNorm, (const char *) L"/", - sizeof(WCHAR)); + if (fData.cFileName[0] != '\0') { + nativeName = fData.cFileName; } else { - WCHAR *nativeName; - - if (fData.cFileName[0] != '\0') { - nativeName = fData.cFileName; - } else { - nativeName = fData.cAlternateFileName; - } - FindClose(handle); - Tcl_DStringAppend(&dsNorm, (const char *) L"/", - sizeof(WCHAR)); - Tcl_DStringAppend(&dsNorm, - (const char *) nativeName, - (int) (wcslen(nativeName)*sizeof(WCHAR))); + nativeName = fData.cAlternateFileName; } + FindClose(handle); + Tcl_DStringAppend(&dsNorm, (const char *) L"/", + sizeof(WCHAR)); + Tcl_DStringAppend(&dsNorm, + (const char *) nativeName, + (int) (wcslen(nativeName)*sizeof(WCHAR))); } } + } #endif /* !TclNORM_LONG_PATH */ - Tcl_DStringFree(&ds); - lastValidPathEnd = currentPathEndPosition; - if (cur == 0) { - break; - } + Tcl_DStringFree(&ds); + lastValidPathEnd = currentPathEndPosition; + if (cur == 0) { + break; + } - /* - * If we get here, we've got past one directory delimiter, so - * we know it is no longer a drive. - */ + /* + * If we get here, we've got past one directory delimiter, so + * we know it is no longer a drive. + */ - isDrive = 0; - } - currentPathEndPosition++; + isDrive = 0; } + currentPathEndPosition++; #ifdef TclNORM_LONG_PATH /* diff --git a/win/tclWinInit.c b/win/tclWinInit.c index f552e2c..d82944e 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -486,13 +486,10 @@ TclpSetInitialEncodings(void) Tcl_DStringFree(&encodingName); } -void -TclpSetInterfaces(void) +void TclWinSetInterfaces( + int dummy) /* Not used. */ { - int useWide; - - useWide = (TclWinGetPlatformId() != VER_PLATFORM_WIN32_WINDOWS); - TclWinSetInterfaces(useWide); + TclpSetInterfaces(); } const char * diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index d418a3e..13caba9 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -1049,15 +1049,8 @@ TclpCreateProcess( * sink. */ - if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) - && (applType == APPL_DOS)) { - if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) { - CloseHandle(h); - } - } else { - startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0, - &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); - } + startInfo.hStdOutput = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0, + &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); } else { DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS); @@ -1076,7 +1069,7 @@ TclpCreateProcess( * sink. */ - startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0, + startInfo.hStdError = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0, &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); } else { DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, -- cgit v0.12 From e05de40e35185e3d3f0dfea4f61f03ce09fb7277 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 19 Jun 2013 19:33:21 +0000 Subject: More use of simplifying macros. Replace dynamic allocation with automatic storage on the call stack. --- generic/tclCompile.c | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index be5bedf..92875a2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1762,7 +1762,7 @@ TclCompileScript( /* TIP #280 */ ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int *wlines, wlineat, cmdLine, *clNext; - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse parse, *parsePtr = &parse; if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); @@ -2190,11 +2190,10 @@ TclCompileScript( */ if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushStringLiteral(envPtr, ""); } envPtr->numSrcBytes = p - script; - TclStackFree(interp, parsePtr); } /* @@ -2258,7 +2257,7 @@ TclCompileVarSubst( localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); } if (localVar < 0) { - TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), envPtr); + PushLiteral(envPtr, name, nameBytes); } /* @@ -2466,7 +2465,7 @@ TclCompileTokens( */ if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushStringLiteral(envPtr, ""); } Tcl_DStringFree(&textBuffer); @@ -2583,7 +2582,7 @@ TclCompileExprWords( for (i = 0; i < numWords; i++) { TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); if (i < (numWords - 1)) { - TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr); + PushStringLiteral(envPtr, " "); } wordPtr += wordPtr->numComponents + 1; } @@ -2638,7 +2637,7 @@ TclCompileNoOp( TclEmitOpcode(INST_POP, envPtr); } } - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushStringLiteral(envPtr, ""); return TCL_OK; } -- cgit v0.12 From 5539977620b9c358a365280e4d0db6a816537b71 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 19 Jun 2013 22:44:42 +0000 Subject: Fixed bug with optimizing with INST_START_CMD about. --- generic/tclOptimize.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 7d4226e..cd37a6a 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -86,6 +86,7 @@ LocateTargetAddresses( case INST_JUMP4: case INST_JUMP_TRUE4: case INST_JUMP_FALSE4: + case INST_START_CMD: targetInstPtr = currentInstPtr+TclGetInt4AtPtr(currentInstPtr+1); goto storeTarget; case INST_BEGIN_CATCH4: @@ -109,8 +110,6 @@ LocateTargetAddresses( DefineTargetAddress(tablePtr, currentInstPtr + 2*i - 1); } break; - case INST_START_CMD: - assert (envPtr->atCmdStart < 2); } } -- cgit v0.12 From 21cf159ca75e16fe0d396af83f2c0342fa7c9913 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 20 Jun 2013 14:17:05 +0000 Subject: TclCompileScript() should not overwrite envPtr->numSrcBytes. The envPtr already has the right value stored in it. --- generic/tclCompile.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cba659d..f982359 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1631,7 +1631,6 @@ TclCompileScript( TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr); } - envPtr->numSrcBytes = (p - script); TclStackFree(interp, parsePtr); Tcl_DStringFree(&ds); } -- cgit v0.12 From c12c83e799a79e5d1faa3dc446e1ef322eaa31fd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Jun 2013 11:53:11 +0000 Subject: Modify internal TclStubInfoType type: use TclStubs * in stead of ClientData, so less type casts are needed in the code. Disadvantage: somewhat more code duplication, but it makes the code much more understandable. --- generic/tclInt.h | 2 +- generic/tclStubLib.c | 27 ++++++++++++++++++++++++--- generic/tclStubLibTbl.c | 15 ++------------- 3 files changed, 27 insertions(+), 17 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 3432b37..c350d15 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3837,7 +3837,7 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, /* Used internally in stub library. */ typedef struct { char version[12]; - ClientData data; + const TclStubs *stubs; } TclStubInfoType; MODULE_SCOPE const char *TclInitStubTable(const char *version); diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index e617515..859cbf9 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -13,6 +13,16 @@ #include "tclInt.h" +MODULE_SCOPE const TclStubs *tclStubsPtr; +MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr; +MODULE_SCOPE const TclIntStubs *tclIntStubsPtr; +MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr; + +const TclStubs *tclStubsPtr = NULL; +const TclPlatStubs *tclPlatStubsPtr = NULL; +const TclIntStubs *tclIntStubsPtr = NULL; +const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; + /* * Use our own isDigit to avoid linking to libc on windows */ @@ -48,7 +58,7 @@ Tcl_InitStubs( { Interp *iPtr = (Interp *) interp; const char *actualVersion = NULL; - TclStubInfoType stub; + ClientData pkgData = NULL; const TclStubs *stubsPtr = iPtr->stubTable; /* @@ -63,7 +73,7 @@ Tcl_InitStubs( return NULL; } - actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &stub.data); + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); if (actualVersion == NULL) { return NULL; } @@ -93,7 +103,18 @@ Tcl_InitStubs( } } } - TclInitStubTable(stub.version); + tclStubsPtr = (TclStubs *)pkgData; + + if (tclStubsPtr->hooks) { + tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; + tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; + tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; + } else { + tclPlatStubsPtr = NULL; + tclIntStubsPtr = NULL; + tclIntPlatStubsPtr = NULL; + } + return actualVersion; } diff --git a/generic/tclStubLibTbl.c b/generic/tclStubLibTbl.c index 0ed057f..0391502 100644 --- a/generic/tclStubLibTbl.c +++ b/generic/tclStubLibTbl.c @@ -13,17 +13,6 @@ #include "tclInt.h" -MODULE_SCOPE const TclStubs *tclStubsPtr; -MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr; -MODULE_SCOPE const TclIntStubs *tclIntStubsPtr; -MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr; - -const TclStubs *tclStubsPtr = NULL; -const TclPlatStubs *tclPlatStubsPtr = NULL; -const TclIntStubs *tclIntStubsPtr = NULL; -const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; - - /* *---------------------------------------------------------------------- * @@ -45,8 +34,7 @@ TclInitStubTable( const char *version) /* points to the version field of a TclStubInfoType structure variable. */ { - const TclStubInfoType *ptr = (const TclStubInfoType *) version; - tclStubsPtr = (const TclStubs *) ptr->data; + tclStubsPtr = ((const TclStubInfoType *) version)->stubs; if (tclStubsPtr->hooks) { tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; @@ -57,6 +45,7 @@ TclInitStubTable( tclIntStubsPtr = NULL; tclIntPlatStubsPtr = NULL; } + return version; } -- cgit v0.12 From 694837ab79cb2b7f05fccf857081bb8a7579079e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Jun 2013 11:57:59 +0000 Subject: Don't use TclpInetNtoa any more, use inet_ntoa in stead. Since IP6 support it's even not necessary any more (except for fake-rfc2553, but mutexes are used here already) , but it's in the internal stub table so we cannot remove it until 9.0 --- generic/tclIntPlatDecls.h | 2 ++ generic/tclStubInit.c | 1 + unix/tclUnixPort.h | 2 -- unix/tclUnixThrd.c | 1 + win/tclWinSock.c | 1 + 5 files changed, 5 insertions(+), 2 deletions(-) diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index dcf1753..3181d4e 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -545,6 +545,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpGmtime_unix #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError +#undef TclpInetNtoa +#define TclpInetNtoa inet_ntoa #if defined(__WIN32__) || defined(__CYGWIN__) # undef TclWinNToHS diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1b04542..782bbdf 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -43,6 +43,7 @@ #undef TclSockMinimumBuffers #define TclBackgroundException Tcl_BackgroundException #undef Tcl_SetIntObj +#undef TclpInetNtoa /* See bug 510001: TclSockMinimumBuffers needs plat imp */ #ifdef _WIN64 diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index fde1909..2ade1c0 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -700,8 +700,6 @@ typedef int socklen_t; #ifdef TCL_THREADS # include -# undef inet_ntoa -# define inet_ntoa(x) TclpInetNtoa(x) #endif /* TCL_THREADS */ /* FIXME - Hyper-enormous platform assumption! */ diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 789dbb6..f469341 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -659,6 +659,7 @@ TclpReaddir( return TclOSreaddir(dir); } +#undef TclpInetNtoa char * TclpInetNtoa( struct in_addr addr) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 1a74354..4ced0e7 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -2735,6 +2735,7 @@ TclWinSetSockOpt( return setsockopt(s, level, optname, optval, optlen); } +#undef TclpInetNtoa char * TclpInetNtoa( struct in_addr addr) -- cgit v0.12 From 4b9c60ce47062894652d4db2156a9643a9b80bb2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 25 Jun 2013 10:02:14 +0000 Subject: Remove TclInitStubTable() function (but keep it in the "initsubsystems" branch). --- generic/tclInt.h | 8 -------- unix/Makefile.in | 6 +----- win/Makefile.in | 4 ---- win/makefile.bc | 4 ---- win/makefile.vc | 4 ---- win/tcl.dsp | 4 ---- 6 files changed, 1 insertion(+), 29 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index c350d15..fdd577a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3834,14 +3834,6 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -/* Used internally in stub library. */ -typedef struct { - char version[12]; - const TclStubs *stubs; -} TclStubInfoType; - -MODULE_SCOPE const char *TclInitStubTable(const char *version); - /* * Functions defined in generic/tclVar.c and currenttly exported only for use * by the bytecode compiler and engine. Some of these could later be placed in diff --git a/unix/Makefile.in b/unix/Makefile.in index 5295a45..f0a729f 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,7 +335,7 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o -STUB_LIB_OBJS = tclStubLib.o tclStubLibTbl.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} +STUB_LIB_OBJS = tclStubLib.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ @@ -470,7 +470,6 @@ OO_SRCS = \ STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ - $(GENERIC_DIR)/tclStubLibTbl.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c @@ -1686,9 +1685,6 @@ Zzutil.o: $(ZLIB_DIR)/zutil.c tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c -tclStubLibTbl.o: $(GENERIC_DIR)/tclStubLibTbl.c - $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLibTbl.c - tclTomMathStubLib.o: $(GENERIC_DIR)/tclTomMathStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclTomMathStubLib.c diff --git a/win/Makefile.in b/win/Makefile.in index d7b25b7..47f3fdd 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -385,7 +385,6 @@ REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ - tclStubLibTbl.$(OBJEXT) \ tclTomMathStubLib.$(OBJEXT) \ tclOOStubLib.$(OBJEXT) @@ -516,9 +515,6 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c tclStubLib.${OBJEXT}: tclStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) -tclStubLibTbl.${OBJEXT}: tclStubLibTbl.c - $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) - tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) diff --git a/win/makefile.bc b/win/makefile.bc index 2726dad..0b17cea 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -279,7 +279,6 @@ TCLOBJS = \ TCLSTUBOBJS = \ $(TMPDIR)\tclStubLib.obj \ - $(TMPDIR)\tclStubLibTbl.obj \ $(TMPDIR)\tclTomMathStubLib.obj \ $(TMPDIR)\tclOOStubLib.obj @@ -529,9 +528,6 @@ $(TMPDIR)\tclWinDde.obj : $(WINDIR)\tclWinDde.c $(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? -$(TMPDIR)\tclStubLibTbl.obj : $(GENERICDIR)\tclStubLibTbl.c - $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? - $(TMPDIR)\tclTomMathStubLib.obj : $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? diff --git a/win/makefile.vc b/win/makefile.vc index c24534a..cddb253 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -450,7 +450,6 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ - $(TMP_DIR)\tclStubLibTbl.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj @@ -980,9 +979,6 @@ $(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)\tclStubLibTbl.obj: $(GENERICDIR)\tclStubLibTbl.c - $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? - $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? diff --git a/win/tcl.dsp b/win/tcl.dsp index 2708051..57ec6bf 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1300,10 +1300,6 @@ SOURCE=..\generic\tclStubLib.c # End Source File # Begin Source File -SOURCE=..\generic\tclStubLibTbl.c -# End Source File -# Begin Source File - SOURCE=..\generic\tclOOStubLib.c # End Source File # Begin Source File -- cgit v0.12 From 61ab4e7385f66e8fbbfdae5b63d6548c62875ceb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 25 Jun 2013 12:02:56 +0000 Subject: Don't use deprecated Tcl_DStringTrunc any more. --- generic/tclTest.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 1ba73e7..9ef7805 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1848,7 +1848,7 @@ TestdstringCmd( if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringTrunc(&dstring, count); + Tcl_DStringSetLength(&dstring, count); } else if (strcmp(argv[1], "start") == 0) { if (argc != 2) { goto wrongNumArgs; -- cgit v0.12 From 0e6dbfcf9977281189ce5a639d1ea673a6a29eda Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 25 Jun 2013 14:19:39 +0000 Subject: Branch for rewriting TclCompileScript() and related routines, with the intent to generally simplify and make more readable, as well as find and eliminate duplication with ensemble machinery and improve mergeability to other branches. Work in Progress. Doesn't work at all right now. --- generic/tclCompile.c | 124 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 124 insertions(+) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 8cb53f5..eafecbc 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1737,6 +1737,37 @@ FindCompiledCommandFromToken( *---------------------------------------------------------------------- */ +#if 1 +static void +CompileCommandTokens( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + CompileEnv *envPtr) +{ + Tcl_Obj *cmdObj; + Tcl_Token *cmdTokenPtr = parsePtr->tokenPtr; + + + if (parsePtr->numWords == 0) { + return 0; + } + + if (!TclWordKnownAtCompileTime(cmdTokenPtr, cmdObj)) { + /* + * Command is not known until runtime substitution is complete. + * Emit instructions to perform that substitution. + */ + CompileTokens(interp, cmdTokenPtr, envPtr); + + } + + + + TclEmitOpcode(INST_POP, envPtr); + +} +#endif + void TclCompileScript( Tcl_Interp *interp, /* Used for error and status reporting. Also @@ -1748,6 +1779,98 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { +#if 1 + unsigned char *entryCodeNext = envPtr->codeNext; + const char *p; + int cmdLine, *clNext; + + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); + } + + /* + * Each iteration through the following loop compiles the next command + * from the script. + */ + + p = script; + cmdLine = envPtr->line; + clNext = envPtr->clNext; + while (numBytes > 0) { + Tcl_Parse parse; + const char *next; + + /* TODO: can we relocate this to happen less frequently? */ + Tcl_ResetResult(interp); + if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) { + /* + * Compile bytecodes to report the parse error at runtime. + */ + + Tcl_LogCommandInfo(interp, script, parse.commandStart, + parse.term - parse.commandStart); + TclCompileSyntaxError(interp, envPtr); + break; + } + + /* + * TIP #280: Count newlines before the command start. + * (See test info-30.33). + */ + + TclAdvanceLines(&cmdLine, p, parse.commandStart); + TclAdvanceContinuations(&cmdLine, &clNext, + parse.commandStart - envPtr->source); + +#ifdef TCL_COMPILE_DEBUG + /* + * If tracing, print a line for each top level command compiled. + */ + + if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + fprintf(stdout, " Compiling: "); + TclPrintSource(stdout, parse.commandStart, + TclMin(parse.term - parse.commandStart, 55)); + fprintf(stdout, "\n"); + } +#endif + + CompileCommandTokens(interp, &parse, envPtr); + + /* + * Advance to the next command in the script. + */ + + next = parse.commandStart + parse.commandSize; + numBytes -= next - p; + p = next; + + /* + * TIP #280: Track lines in the just compiled command. + */ + + TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); + TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); + Tcl_FreeParse(&parse); + } + + /* + * TIP #280: Bring the line counts in the CompEnv up to date. + * See tests info-30.33,34,35 . + */ + + envPtr->line = cmdLine; + envPtr->clNext = clNext; + + /* + * If the source script yielded no instructions (e.g., if it was empty), + * push an empty string as the command's result. + */ + + if (envPtr->codeNext == entryCodeNext) { + PushStringLiteral(envPtr, ""); + } +#else int lastTopLevelCmdIndex = -1; /* Index of most recent toplevel command in * the command location table. Initialized to @@ -2192,6 +2315,7 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); } +#endif } /* -- cgit v0.12 From edc81d994ec2f31a92dec97ec8dd28d5de990c93 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 25 Jun 2013 15:01:03 +0000 Subject: Make more use of the CompileTokens() macro. --- generic/tclCompExpr.c | 3 +-- generic/tclCompile.c | 8 +++----- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index efdc2b0..2a48117 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2486,8 +2486,7 @@ CompileExprTree( break; } case OT_TOKENS: - TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, - envPtr); + CompileTokens(envPtr, tokenPtr, interp); tokenPtr += tokenPtr->numComponents + 1; break; default: diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 8cb53f5..ccf8938 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1936,8 +1936,7 @@ TclCompileScript( * The word is not a simple string of characters. */ - TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); + CompileTokens(envPtr, tokenPtr, interp); if (expand && tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { TclEmitInstInt4(INST_EXPAND_STKTOP, envPtr->currStackDepth, envPtr); @@ -2578,7 +2577,7 @@ TclCompileExprWords( wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { - TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); + CompileTokens(envPtr, wordPtr, interp); if (i < (numWords - 1)) { PushStringLiteral(envPtr, " "); } @@ -2630,8 +2629,7 @@ TclCompileNoOp( tokenPtr = tokenPtr + tokenPtr->numComponents + 1; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, - envPtr); + CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); } } -- cgit v0.12 From 6ed69603db59ee390437a9eb54685869393a243c Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 25 Jun 2013 19:23:24 +0000 Subject: Replace always true test with assertion. --- generic/tclCompile.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ccf8938..633966e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2098,6 +2098,7 @@ TclCompileScript( * Emit an invoke instruction for the command. We skip this if a * compile procedure was found for the command. */ + assert(wordIdx > 0); if (expand) { /* @@ -2119,7 +2120,7 @@ TclCompileScript( TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); envPtr->expandCount--; TclAdjustStackDepth(1 - wordIdx, envPtr); - } else if (wordIdx > 0) { + } else { /* * Save PC -> command map for the TclArgumentBC* functions. */ -- cgit v0.12 From 9b8f81698635aaedfb4f36d41d4d8779e754ce11 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 25 Jun 2013 20:22:31 +0000 Subject: Nearly functional now, but leaky and not yet as tidy as I'm hoping for. --- generic/tclCompile.c | 301 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 289 insertions(+), 12 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 01320cf..2c6af46 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1744,27 +1744,295 @@ CompileCommandTokens( Tcl_Parse *parsePtr, CompileEnv *envPtr) { - Tcl_Obj *cmdObj; - Tcl_Token *cmdTokenPtr = parsePtr->tokenPtr; - + Interp *iPtr = (Interp *) interp; + Tcl_Obj *cmdObj = Tcl_NewObj(); + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + Command *cmdPtr = NULL; + int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + int *wlines, wlineat; - if (parsePtr->numWords == 0) { - return 0; + if (numWords == 0) { + return; + } + + for (wordIdx = 0; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + expand = 1; + break; + } } - if (!TclWordKnownAtCompileTime(cmdTokenPtr, cmdObj)) { + Tcl_IncrRefCount(cmdObj); + tokenPtr = parsePtr->tokenPtr; + cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); + + if (cmdKnown && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if (cmdPtr) { + /* + * Found a command. Test all the ways we can be told + * not to attempt to compile it. + */ + if ((cmdPtr->compileProc == NULL) + || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES) + || (expand && !(cmdPtr->flags & CMD_COMPILES_EXPANDED))) { + cmdPtr = NULL; + } + } + } + + /* Pre-Compile */ +int lastTopLevelCmdIndex, currCmdIndex, startCodeOffset; + +int cmdLine = envPtr->line; +int *clNext = envPtr->clNext; + + lastTopLevelCmdIndex = currCmdIndex = envPtr->numCommands; + envPtr->numCommands++; + startCodeOffset = envPtr->codeNext - envPtr->codeStart; + EnterCmdStartData(envPtr, currCmdIndex, + parsePtr->commandStart - envPtr->source, startCodeOffset); + + if (expand && !cmdPtr) { + StartExpanding(envPtr); + } + + /* + * TIP #280. Scan the words and compute the extended location + * information. The map first contain full per-word line + * information for use by the compiler. This is later replaced by + * a reduced form which signals non-literal words, stored in + * 'wlines'. + */ + + EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, + parsePtr->tokenPtr, parsePtr->commandStart, + parsePtr->commandSize, parsePtr->numWords, cmdLine, + clNext, &wlines, envPtr); + wlineat = eclPtr->nuloc - 1; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + + if (cmdPtr) { + int savedNumCmds = envPtr->numCommands; + int update = 0; + int startStackDepth = envPtr->currStackDepth; + + /* + * Mark the start of the command; the proper bytecode + * length will be updated later. There is no need to + * do this for the first bytecode in the compile env, + * as the check is done before calling + * TclNRExecuteByteCode(). Do emit an INST_START_CMD + * in special cases where the first bytecode is in a + * loop, to insure that the corresponding command is + * counted properly. Compilers for commands able to + * produce such a beast (currently 'while 1' only) set + * envPtr->atCmdStart to 0 in order to signal this + * case. [Bug 1752146] + * + * Note that the environment is initialised with + * atCmdStart=1 to avoid emitting ISC for the first + * command. + */ + + if (envPtr->atCmdStart == 1) { + if (startCodeOffset) { + /* + * Increase the number of commands being + * started at the current point. Note that + * this depends on the exact layout of the + * INST_START_CMD's operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) + } + } else if (envPtr->atCmdStart == 0) { + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + TclEmitInt4(1, envPtr); + update = 1; + } + + if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { + +#ifdef TCL_COMPILE_DEBUG + /* + * Confirm that the command compiler generated a + * single value on the stack as its result. This + * is only done in debugging mode, as it *should* + * be correct and normal users have no reasonable + * way to fix it anyway. + */ + + int diff = envPtr->currStackDepth - startStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", + parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif + if (update) { + /* + * Fix the bytecode length. + */ + + unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; + unsigned fixLen = envPtr->codeNext - fixPtr + 1; + + TclStoreInt4AtPtr(fixLen, fixPtr); + } + goto finishCommand; + } + + if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { + /* + * Decrease the number of commands being started + * at the current point. Note that this depends on + * the exact layout of the INST_START_CMD's + * operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); + } + /* - * Command is not known until runtime substitution is complete. - * Emit instructions to perform that substitution. + * Restore numCommands, codeNext, and currStackDepth to their + * correct values, removing any commands compiled before the + * failure to produce bytecode got reported. + * [Bugs 705406, 735055, 3614102] */ - CompileTokens(interp, cmdTokenPtr, envPtr); + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart + startCodeOffset; + envPtr->currStackDepth = startStackDepth; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + + /* TODO: Can this happen? If so, is this right? */ + if (expand) { + StartExpanding(envPtr); + } } - + /* + * No complile attempted, or it failed. + * Need to emit instructions to invoke, with expansion if needed. + */ + + wordIdx = 0; + tokenPtr = parsePtr->tokenPtr; + if (cmdKnown) { + int cmdLitIdx, numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + + cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if (cmdPtr) { + TclSetCmdNameObj(interp, + TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); + wordIdx = 1; + tokenPtr += tokenPtr->numComponents + 1; + } + + for (; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + int objIdx; + + envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, + eclPtr->loc[wlineat].next[wordIdx]); + } + TclEmitPush(objIdx, envPtr); + } + + /* + * Emit an invoke instruction for the command. We skip this if a + * compile procedure was found for the command. + */ + + if (expand) { + /* + * The stack depth during argument expansion can only be + * managed at runtime, as the number of elements in the + * expanded lists is not known at compile time. We adjust here + * the stack depth estimate so that it is correct after the + * command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the + * words of the command are popped from the stack, and the + * result is pushed: the stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command + * is being prepared and run, INST_EXPAND_STKTOP is not + * stack-neutral in general. + */ + + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - wordIdx, envPtr); + } else { + /* + * Save PC -> command map for the TclArgumentBC* functions. + */ + + int isnew; + Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, + INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew); + + Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } + } + +finishCommand: TclEmitOpcode(INST_POP, envPtr); + EnterCmdExtentData(envPtr, currCmdIndex, + parsePtr->term - parsePtr->commandStart, + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + if (cmdKnown) { + Tcl_DecrRefCount(cmdObj); + } + + /* + * TIP #280: Free full form of per-word line data and insert the + * reduced form now + */ + + envPtr->line = cmdLine; + envPtr->clNext = clNext; + ckfree(eclPtr->loc[wlineat].line); + ckfree(eclPtr->loc[wlineat].next); + eclPtr->loc[wlineat].line = wlines; + eclPtr->loc[wlineat].next = NULL; } #endif @@ -1828,14 +2096,19 @@ TclCompileScript( */ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + int commandLength = parse.term - parse.commandStart; fprintf(stdout, " Compiling: "); TclPrintSource(stdout, parse.commandStart, - TclMin(parse.term - parse.commandStart, 55)); + TclMin(commandLength, 55)); fprintf(stdout, "\n"); } #endif + envPtr->line = cmdLine; + envPtr->clNext = clNext; CompileCommandTokens(interp, &parse, envPtr); + cmdLine = envPtr->line; + clNext = envPtr->clNext; /* * Advance to the next command in the script. @@ -1849,7 +2122,7 @@ TclCompileScript( * TIP #280: Track lines in the just compiled command. */ - TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); + TclAdvanceLines(&cmdLine, parse.commandStart, p); TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); Tcl_FreeParse(&parse); } @@ -1869,6 +2142,10 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); + } else { + /* Remove the surplus INST_POP */ + envPtr->codeNext--; + TclAdjustStackDepth(1, envPtr); } #else int lastTopLevelCmdIndex = -1; -- cgit v0.12 From a0860b63fb252ca05d70706533db45c410b95c0e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Jun 2013 03:46:54 +0000 Subject: A few bug fixes from failing tests; still leaky. --- generic/tclCompile.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 955078c..626c5ae 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2076,7 +2076,10 @@ TclCompileScript( */ Tcl_LogCommandInfo(interp, script, parse.commandStart, - parse.term - parse.commandStart); + /* Drop the command terminator (";","]") if appropriate */ + (parse.term == + parse.commandStart + parse.commandSize - 1)? + parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); break; } @@ -2142,7 +2145,7 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); - } else { + } else if (envPtr->codeNext[-1] == INST_POP) { /* Remove the surplus INST_POP */ envPtr->codeNext--; TclAdjustStackDepth(1, envPtr); -- cgit v0.12 From b7baefb37be1711dc8aefbbed9e9670b0926e1be Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Jun 2013 07:42:53 +0000 Subject: Proposed solution for [9b2e636361] --- generic/tclConfig.c | 44 +++++++++++++++++++------------------------- generic/tclMain.c | 5 +++-- 2 files changed, 22 insertions(+), 27 deletions(-) diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 28549ed..ffed6f2 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -26,14 +26,15 @@ #define ASSOC_KEY "tclPackageAboutDict" /* - * A ClientData struct for the QueryConfig command. Store the two bits + * A ClientData struct for the QueryConfig command. Store the three bits * of data we need; the package name for which we store a config dict, - * and the (Tcl_Interp *) in which it is stored. + * the (Tcl_Interp *) in which it is stored, and the encoding. */ typedef struct QCCD { Tcl_Obj *pkg; Tcl_Interp *interp; + CONST char *encoding; } QCCD; /* @@ -78,10 +79,10 @@ Tcl_RegisterConfig( Tcl_Obj *pDB, *pkgDict; Tcl_DString cmdName; Tcl_Config *cfg; - Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding); QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD)); cdPtr->interp = interp; + cdPtr->encoding = valEncoding; cdPtr->pkg = Tcl_NewStringObj(pkgName, -1); /* @@ -104,7 +105,6 @@ Tcl_RegisterConfig( * dictionaries visible at Tcl level. I.e. they are not filled */ - if (venc != NULL) { /* * Retrieve package specific configuration... */ @@ -123,32 +123,15 @@ Tcl_RegisterConfig( */ for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) { - Tcl_DString conv; - CONST char *convValue = - Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv); - - /* - * We know that the keys are in ASCII/UTF-8, so for them is no - * conversion required. - */ - Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), - Tcl_NewStringObj(convValue, -1)); - Tcl_DStringFree(&conv); + Tcl_NewStringObj(cfg->value, -1)); } /* - * We're now done with the encoding, so drop it. - */ - - Tcl_FreeEncoding(venc); - - /* * Write the changes back into the overall database. */ Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict); - } /* * Now create the interface command for retrieval of the package @@ -219,6 +202,9 @@ QueryConfigObjCmd( enum subcmds { CFG_GET, CFG_LIST }; + Tcl_DString conv; + Tcl_Encoding venc = NULL; + CONST char *value; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?"); @@ -237,7 +223,7 @@ QueryConfigObjCmd( * present. */ - Tcl_SetResult(interp, "package not known", TCL_STATIC); + Tcl_SetResult(interp, "package not known", TCL_STATIC); return TCL_ERROR; } @@ -254,7 +240,15 @@ QueryConfigObjCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, val); + if (cdPtr->encoding) { + venc = Tcl_GetEncoding(interp, cdPtr->encoding); + if (!venc) { + return TCL_ERROR; + } + } + value = Tcl_ExternalToUtfDString(venc, Tcl_GetString(val), -1, &conv); + Tcl_SetObjResult(interp, Tcl_NewStringObj(value, -1)); + Tcl_DStringFree(&conv); return TCL_OK; case CFG_LIST: @@ -361,7 +355,7 @@ GetConfigDict( * * This function is associated with the "Package About dict" assoc data * for an interpreter; it is invoked when the interpreter is deleted in - * order to free the information assoicated with any pending error + * order to free the information associated with any pending error * reports. * * Results: diff --git a/generic/tclMain.c b/generic/tclMain.c index 7a19a38..5e5109b 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -342,9 +342,10 @@ Tcl_Main( Tcl_Interp *interp; Tcl_DString appName; - Tcl_FindExecutable(argv[0]); - interp = Tcl_CreateInterp(); + TclpSetInitialEncodings(); + TclpFindExecutable(argv[0]); + Tcl_InitMemory(interp); /* -- cgit v0.12 From e0e8990257bc75fdafa895f309145353c400923e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Jun 2013 08:10:36 +0000 Subject: Allocate encoding name, so caller of Tcl_RegisterConfig() doesn't need to keep it forever. Fix some comments. --- generic/tclConfig.c | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/generic/tclConfig.c b/generic/tclConfig.c index ffed6f2..702ab82 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -34,7 +34,7 @@ typedef struct QCCD { Tcl_Obj *pkg; Tcl_Interp *interp; - CONST char *encoding; + char *encoding; } QCCD; /* @@ -82,15 +82,20 @@ Tcl_RegisterConfig( QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD)); cdPtr->interp = interp; - cdPtr->encoding = valEncoding; + if (valEncoding) { + cdPtr->encoding = ckalloc(strlen(valEncoding)+1); + strcpy(cdPtr->encoding, valEncoding); + } else { + cdPtr->encoding = NULL; + } cdPtr->pkg = Tcl_NewStringObj(pkgName, -1); /* * Phase I: Adding the provided information to the internal database of - * package meta data. Only if we have an ok encoding. + * package meta data. * * Phase II: Create a command for querying this database, specific to the - * package registerting its configuration. This is the approved interface + * package registering its configuration. This is the approved interface * in TIP 59. In the future a more general interface should be done, as * followup to TIP 59. Simply because our database is now general across * packages, and not a structure tied to one package. @@ -313,6 +318,9 @@ QueryConfigDelete( Tcl_Obj *pDB = GetConfigDict(cdPtr->interp); Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); + if (cdPtr->encoding) { + ckfree((char *)cdPtr->encoding); + } ckfree((char *)cdPtr); } -- cgit v0.12 From 75b009d2316ab41a1ff6bd841da8fd207aba7b9d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Jun 2013 14:20:26 +0000 Subject: formatting, typo --- generic/tclConfig.c | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 28549ed..c6baa2f 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -75,7 +75,6 @@ Tcl_RegisterConfig( CONST char *valEncoding) /* Name of the encoding used to store the * configuration values, ASCII, thus UTF-8. */ { - Tcl_Obj *pDB, *pkgDict; Tcl_DString cmdName; Tcl_Config *cfg; Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding); @@ -89,9 +88,9 @@ Tcl_RegisterConfig( * package meta data. Only if we have an ok encoding. * * Phase II: Create a command for querying this database, specific to the - * package registerting its configuration. This is the approved interface + * package registering its configuration. This is the approved interface * in TIP 59. In the future a more general interface should be done, as - * followup to TIP 59. Simply because our database is now general across + * follow-up to TIP 59. Simply because our database is now general across * packages, and not a structure tied to one package. * * Note, the created command will have a reference through its clientdata. @@ -105,14 +104,14 @@ Tcl_RegisterConfig( */ if (venc != NULL) { + Tcl_Obj *pkgDict, *pDB = GetConfigDict(interp); + /* * Retrieve package specific configuration... */ - pDB = GetConfigDict(interp); - if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK - || (pkgDict == NULL)) { + || (pkgDict == NULL)) { pkgDict = Tcl_NewDictObj(); } else if (Tcl_IsShared(pkgDict)) { pkgDict = Tcl_DuplicateObj(pkgDict); @@ -125,7 +124,7 @@ Tcl_RegisterConfig( for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) { Tcl_DString conv; CONST char *convValue = - Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv); + Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv); /* * We know that the keys are in ASCII/UTF-8, so for them is no @@ -133,7 +132,7 @@ Tcl_RegisterConfig( */ Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), - Tcl_NewStringObj(convValue, -1)); + Tcl_NewStringObj(convValue, -1)); Tcl_DStringFree(&conv); } @@ -178,7 +177,7 @@ Tcl_RegisterConfig( if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), QueryConfigObjCmd, (ClientData) cdPtr, QueryConfigDelete) == NULL) { - Tcl_Panic("%s: %s", "Tcl_RegisterConfig", + Tcl_Panic("%s: %s", "Tcl_RegisterConfig", "Unable to create query command for package configuration"); } @@ -213,7 +212,7 @@ QueryConfigObjCmd( Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; int n, index; - static const char *subcmdStrings[] = { + static CONST char *subcmdStrings[] = { "get", "list", NULL }; enum subcmds { @@ -232,12 +231,12 @@ QueryConfigObjCmd( pDB = GetConfigDict(interp); if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK || pkgDict == NULL) { - /* + /* * Maybe a Tcl_Panic is better, because the package data has to be * present. */ - Tcl_SetResult(interp, "package not known", TCL_STATIC); + Tcl_SetResult(interp, "package not known", TCL_STATIC); return TCL_ERROR; } @@ -248,7 +247,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - if (Tcl_DictObjGet(interp, pkgDict, objv [2], &val) != TCL_OK + if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK || val == NULL) { Tcl_SetResult(interp, "key not known", TCL_STATIC); return TCL_ERROR; @@ -317,6 +316,7 @@ QueryConfigDelete( QCCD *cdPtr = (QCCD *) clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB = GetConfigDict(cdPtr->interp); + Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); ckfree((char *)cdPtr); -- cgit v0.12 From 33e20f17a6f8a5fddafb1a39563a04aed53705e1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Jun 2013 16:06:44 +0000 Subject: Fix bytecode ranges in the cmdMapPtr. still leaky. --- generic/tclCompile.c | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 626c5ae..62943b2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1742,7 +1742,8 @@ static void CompileCommandTokens( Tcl_Interp *interp, Tcl_Parse *parsePtr, - CompileEnv *envPtr) + CompileEnv *envPtr, + int *lastPopPtr) { Interp *iPtr = (Interp *) interp; Tcl_Obj *cmdObj = Tcl_NewObj(); @@ -2017,6 +2018,8 @@ finishCommand: EnterCmdExtentData(envPtr, currCmdIndex, parsePtr->term - parsePtr->commandStart, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + *lastPopPtr = currCmdIndex; + if (cmdKnown) { Tcl_DecrRefCount(cmdObj); @@ -2051,6 +2054,7 @@ TclCompileScript( unsigned char *entryCodeNext = envPtr->codeNext; const char *p; int cmdLine, *clNext; + int lastPop = -1; if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); @@ -2081,6 +2085,7 @@ TclCompileScript( parse.commandStart + parse.commandSize - 1)? parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); + lastPop = -1; break; } @@ -2109,7 +2114,7 @@ TclCompileScript( envPtr->line = cmdLine; envPtr->clNext = clNext; - CompileCommandTokens(interp, &parse, envPtr); + CompileCommandTokens(interp, &parse, envPtr, &lastPop); cmdLine = envPtr->line; clNext = envPtr->clNext; @@ -2145,8 +2150,8 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); - } else if (envPtr->codeNext[-1] == INST_POP) { - /* Remove the surplus INST_POP */ + } else if (lastPop >= 0) { + envPtr->cmdMapPtr[lastPop].numCodeBytes--; envPtr->codeNext--; TclAdjustStackDepth(1, envPtr); } -- cgit v0.12 From d586d955ce5e6ebbd9b670d848ef7c4f4935f9f3 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Jun 2013 17:26:16 +0000 Subject: Correct typo detected by valgrind. --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 98f1ed8..d3a0d32 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2766,7 +2766,7 @@ TEBCresume( */ auxObjList->length += objc - 1; - if ((objc > 1) && (auxObjList-length > 0)) { + if ((objc > 1) && (auxObjList->length > 0)) { length = auxObjList->length /* Total expansion room we need */ + codePtr->maxStackDepth /* Beyond the original max */ - CURR_DEPTH; /* Relative to where we are */ -- cgit v0.12 From d8e108cc4748d02d928366cc07447b2e738e796b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Jun 2013 20:13:57 +0000 Subject: Stop buffer overrun into undefined values detected by valgrind. --- generic/tclOptimize.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index cd37a6a..b7f4173 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -212,7 +212,8 @@ ConvertZeroEffectToNOP( int blank = 0, i, nextInst; size = AddrLength(currentInstPtr); - while (*(currentInstPtr+size) == INST_NOP) { + while ((currentInstPtr + size < envPtr->codeNext) + && *(currentInstPtr+size) == INST_NOP) { if (IsTargetAddress(&targets, currentInstPtr + size)) { break; } -- cgit v0.12 From 4afe34c9b3d9bc56352470e7f7dc61304bb71201 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 27 Jun 2013 12:34:49 +0000 Subject: Fix [34538ba43f] --- library/clock.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/clock.tcl b/library/clock.tcl index 32911b3..49aad23 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -3947,7 +3947,7 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { # Put DST in effect in all years from 1916 to 2099. - for { set y 1916 } { $y < 2099 } { incr y } { + for { set y 1916 } { $y < 2100 } { incr y } { set startTime [DeterminePosixDSTTime $z start $y] incr startTime [expr { - wide($stdOffset) }] set endTime [DeterminePosixDSTTime $z end $y] -- cgit v0.12 From e72d24628cda082e00cafb1ec1e95ea027dc66c8 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Jun 2013 13:11:53 +0000 Subject: plug memory leaks --- generic/tclCompile.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 62943b2..416078c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1746,7 +1746,7 @@ CompileCommandTokens( int *lastPopPtr) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *cmdObj = Tcl_NewObj(); + Tcl_Obj *cmdObj; Tcl_Token *tokenPtr = parsePtr->tokenPtr; Command *cmdPtr = NULL; int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; @@ -1765,6 +1765,7 @@ CompileCommandTokens( } } + cmdObj = Tcl_NewObj(); Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); @@ -2085,6 +2086,7 @@ TclCompileScript( parse.commandStart + parse.commandSize - 1)? parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); + Tcl_FreeParse(&parse); lastPop = -1; break; } -- cgit v0.12 From 7924f4a694c43ca8fe4260041d090795b0791a96 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Jun 2013 20:10:41 +0000 Subject: Stop the compileProc routines leaving behind error messages in interp. (Nicer way to solve [Bug 20a81392ec].) Make simplifications in TclCompileScript() make possible by the new structure. Still a work in progress. --- generic/tclAssembly.c | 32 +++++++++++++- generic/tclCompCmds.c | 5 ++- generic/tclCompCmdsGR.c | 1 + generic/tclCompile.c | 109 ++++++++++++++++++++++-------------------------- 4 files changed, 83 insertions(+), 64 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 62641e6..1a061f0 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -930,6 +930,12 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ +#if 0 + int numCommands = envPtr->numCommands; + int offset = envPtr->codeNext - envPtr->codeStart; + int depth = envPtr->currStackDepth; +#endif + /* * Make sure that the command has a single arg that is a simple word. */ @@ -943,10 +949,32 @@ TclCompileAssembleCmd( } /* - * Compile the code and return any error from the compilation. + * Compile the code and convert any error from the compilation into + * bytecode reporting the error; */ - return TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0); + if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, + tokenPtr[1].size, TCL_EVAL_DIRECT)) { + + /* + * TODO: Finish working out how to capture syntax errors captured + * during compile and make them bytecode reporting the error. + */ +#if 0 + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%.*s\" body, line %d)", + parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, + Tcl_GetErrorLine(interp))); + envPtr->numCommands = numCommands; + envPtr->codeNext = envPtr->codeStart + offset; + envPtr->currStackDepth = depth; + TclCompileSyntaxError(interp, envPtr); +#else + Tcl_ResetResult(interp); + return TCL_ERROR; +#endif + } + return TCL_OK; } /* diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fddf152..18295eb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2544,7 +2544,7 @@ CompileEachloopCmd( Tcl_DStringInit(&varList); TclDStringAppendToken(&varList, &tokenPtr[1]); - code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), + code = Tcl_SplitList(NULL, Tcl_DStringValue(&varList), &varcList[loopIndex], &varvList[loopIndex]); Tcl_DStringFree(&varList); if (code != TCL_OK) { @@ -2988,7 +2988,8 @@ TclCompileFormatCmd( ckfree(objv); Tcl_DecrRefCount(formatObj); if (tmpObj == NULL) { - return TCL_ERROR; + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; } /* diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f7c15e6..4de8cf2 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2534,6 +2534,7 @@ TclCompileSyntaxError( TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); + Tcl_ResetResult(interp); } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 416078c..5a8524c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1738,24 +1738,25 @@ FindCompiledCommandFromToken( */ #if 1 -static void +static int CompileCommandTokens( Tcl_Interp *interp, Tcl_Parse *parsePtr, - CompileEnv *envPtr, - int *lastPopPtr) + CompileEnv *envPtr) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *cmdObj; Tcl_Token *tokenPtr = parsePtr->tokenPtr; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + Tcl_Obj *cmdObj = Tcl_NewObj(); Command *cmdPtr = NULL; int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int *wlines, wlineat; + int cmdLine = envPtr->line; + int *clNext = envPtr->clNext; + int cmdIdx = envPtr->numCommands; + int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - if (numWords == 0) { - return; - } + assert (numWords > 0); for (wordIdx = 0; wordIdx < numWords; wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { @@ -1765,7 +1766,6 @@ CompileCommandTokens( } } - cmdObj = Tcl_NewObj(); Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); @@ -1787,15 +1787,9 @@ CompileCommandTokens( } /* Pre-Compile */ -int lastTopLevelCmdIndex, currCmdIndex, startCodeOffset; - -int cmdLine = envPtr->line; -int *clNext = envPtr->clNext; - lastTopLevelCmdIndex = currCmdIndex = envPtr->numCommands; envPtr->numCommands++; - startCodeOffset = envPtr->codeNext - envPtr->codeStart; - EnterCmdStartData(envPtr, currCmdIndex, + EnterCmdStartData(envPtr, cmdIdx, parsePtr->commandStart - envPtr->source, startCodeOffset); if (expand && !cmdPtr) { @@ -2016,11 +2010,9 @@ int *clNext = envPtr->clNext; finishCommand: TclEmitOpcode(INST_POP, envPtr); - EnterCmdExtentData(envPtr, currCmdIndex, + EnterCmdExtentData(envPtr, cmdIdx, parsePtr->term - parsePtr->commandStart, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - *lastPopPtr = currCmdIndex; - if (cmdKnown) { Tcl_DecrRefCount(cmdObj); @@ -2037,6 +2029,8 @@ finishCommand: ckfree(eclPtr->loc[wlineat].next); eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; + + return cmdIdx; } #endif @@ -2052,10 +2046,8 @@ TclCompileScript( CompileEnv *envPtr) /* Holds resulting instructions. */ { #if 1 - unsigned char *entryCodeNext = envPtr->codeNext; - const char *p; - int cmdLine, *clNext; - int lastPop = -1; + int lastCmdIdx = -1; + const char *p = script; if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); @@ -2066,40 +2058,34 @@ TclCompileScript( * from the script. */ - p = script; - cmdLine = envPtr->line; - clNext = envPtr->clNext; + /* TODO: Figure out when/why we need this */ +#if 0 +if (Tcl_GetStringResult(interp)[0] != '\0') { + fprintf(stdout, "INIT: '%s'\n", Tcl_GetStringResult(interp)); + fflush(stdout); +} +#endif + Tcl_ResetResult(interp); while (numBytes > 0) { Tcl_Parse parse; const char *next; - /* TODO: can we relocate this to happen less frequently? */ - Tcl_ResetResult(interp); if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) { /* * Compile bytecodes to report the parse error at runtime. */ Tcl_LogCommandInfo(interp, script, parse.commandStart, +/* TODO: Make this more sensible, f. ex. [eval {foo \$x(}] */ /* Drop the command terminator (";","]") if appropriate */ (parse.term == parse.commandStart + parse.commandSize - 1)? parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); Tcl_FreeParse(&parse); - lastPop = -1; - break; + return; } - /* - * TIP #280: Count newlines before the command start. - * (See test info-30.33). - */ - - TclAdvanceLines(&cmdLine, p, parse.commandStart); - TclAdvanceContinuations(&cmdLine, &clNext, - parse.commandStart - envPtr->source); - #ifdef TCL_COMPILE_DEBUG /* * If tracing, print a line for each top level command compiled. @@ -2114,48 +2100,51 @@ TclCompileScript( } #endif - envPtr->line = cmdLine; - envPtr->clNext = clNext; - CompileCommandTokens(interp, &parse, envPtr, &lastPop); - cmdLine = envPtr->line; - clNext = envPtr->clNext; + /* + * TIP #280: Count newlines before the command start. + * (See test info-30.33). + */ + + TclAdvanceLines(&envPtr->line, p, parse.commandStart); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + parse.commandStart - envPtr->source); /* - * Advance to the next command in the script. + * Advance parser to the next command in the script. */ next = parse.commandStart + parse.commandSize; numBytes -= next - p; p = next; + if (parse.numWords == 0) { + /* TODO: Document justification */ + continue; + } + + lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr); + /* * TIP #280: Track lines in the just compiled command. */ - TclAdvanceLines(&cmdLine, parse.commandStart, p); - TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); + TclAdvanceLines(&envPtr->line, parse.commandStart, p); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + p - envPtr->source); Tcl_FreeParse(&parse); } /* - * TIP #280: Bring the line counts in the CompEnv up to date. - * See tests info-30.33,34,35 . - */ - - envPtr->line = cmdLine; - envPtr->clNext = clNext; - - /* * If the source script yielded no instructions (e.g., if it was empty), * push an empty string as the command's result. */ - if (envPtr->codeNext == entryCodeNext) { - PushStringLiteral(envPtr, ""); - } else if (lastPop >= 0) { - envPtr->cmdMapPtr[lastPop].numCodeBytes--; + if (lastCmdIdx >= 0) { + envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; - TclAdjustStackDepth(1, envPtr); + envPtr->currStackDepth++; + } else { + PushStringLiteral(envPtr, ""); } #else int lastTopLevelCmdIndex = -1; -- cgit v0.12 From d896ae28d39cbaeb363e3b84c58c26e31bd0c56d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Jun 2013 02:58:15 +0000 Subject: More elimination of error message litter to fix [Bug 20a81392ec]. --- generic/tclCompCmdsSZ.c | 3 +++ generic/tclCompile.c | 8 -------- generic/tclExecute.c | 18 +++++++----------- 3 files changed, 10 insertions(+), 19 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 855dd8f..026b214 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -748,6 +748,9 @@ TclSubstCompile( Tcl_InterpState state = NULL; TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); + if (state != NULL) { + Tcl_ResetResult(interp); + } /* * Tricky point! If the first token does not result in a *guaranteed* push diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5a8524c..1f72aa7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2058,14 +2058,6 @@ TclCompileScript( * from the script. */ - /* TODO: Figure out when/why we need this */ -#if 0 -if (Tcl_GetStringResult(interp)[0] != '\0') { - fprintf(stdout, "INIT: '%s'\n", Tcl_GetStringResult(interp)); - fflush(stdout); -} -#endif - Tcl_ResetResult(interp); while (numBytes > 0) { Tcl_Parse parse; const char *next; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d3a0d32..37bf072 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1426,17 +1426,12 @@ Tcl_NRExprObj( Tcl_Obj *resultPtr) { ByteCode *codePtr; + Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK); - /* TODO: consider saving whole state? */ - Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); - - Tcl_IncrRefCount(saveObjPtr); - + Tcl_ResetResult(interp); codePtr = CompileExprObj(interp, objPtr); - /* TODO: Confirm reset not required? */ - /*Tcl_ResetResult(interp);*/ - Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr, + Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr, NULL, NULL); return TclNRExecuteByteCode(interp, codePtr); } @@ -1447,14 +1442,15 @@ ExprObjCallback( Tcl_Interp *interp, int result) { - Tcl_Obj *saveObjPtr = data[0]; + Tcl_InterpState state = data[0]; Tcl_Obj *resultPtr = data[1]; if (result == TCL_OK) { TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_SetObjResult(interp, saveObjPtr); + (void) Tcl_RestoreInterpState(interp, state); + } else { + Tcl_DiscardInterpState(state); } - TclDecrRefCount(saveObjPtr); return result; } -- cgit v0.12 From 5d46ba8b3ec614cfb931011d5b6c35d9eb046d75 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 1 Jul 2013 20:58:15 +0000 Subject: More Work In Progress. --- generic/tclCompile.c | 55 ++++++++++++++++++++++++++++++++-------------------- tests/misc.test | 7 +------ 2 files changed, 35 insertions(+), 27 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1f72aa7..6f5ef50 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -16,6 +16,8 @@ #include "tclCompile.h" #include +#define REWRITE + /* * Table of all AuxData types. */ @@ -562,8 +564,10 @@ static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); +#ifndef REWRITE static Command * FindCompiledCommandFromToken(Tcl_Interp *interp, Tcl_Token *tokenPtr); +#endif static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); @@ -1671,6 +1675,7 @@ TclWordKnownAtCompileTime( return 1; } +#ifndef REWRITE /* * --------------------------------------------------------------------- * @@ -1718,6 +1723,7 @@ FindCompiledCommandFromToken( Tcl_DStringFree(&ds); return cmdPtr; } +#endif /* *---------------------------------------------------------------------- @@ -1737,7 +1743,7 @@ FindCompiledCommandFromToken( *---------------------------------------------------------------------- */ -#if 1 +#ifdef REWRITE static int CompileCommandTokens( Tcl_Interp *interp, @@ -2045,18 +2051,18 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { -#if 1 - int lastCmdIdx = -1; - const char *p = script; +#ifdef REWRITE + int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last + * command this routine compiles into bytecode. + * Initial value of -1 indicates this routine + * has not yet generated any bytecode. */ + const char *p = script; /* Where we are in our compile. */ if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); } - /* - * Each iteration through the following loop compiles the next command - * from the script. - */ + /* Each iteration compiles one command from the script. */ while (numBytes > 0) { Tcl_Parse parse; @@ -2068,11 +2074,7 @@ TclCompileScript( */ Tcl_LogCommandInfo(interp, script, parse.commandStart, -/* TODO: Make this more sensible, f. ex. [eval {foo \$x(}] */ - /* Drop the command terminator (";","]") if appropriate */ - (parse.term == - parse.commandStart + parse.commandSize - 1)? - parse.commandSize - 1 : parse.commandSize); + parse.term + 1 - parse.commandStart); TclCompileSyntaxError(interp, envPtr); Tcl_FreeParse(&parse); return; @@ -2126,17 +2128,28 @@ TclCompileScript( Tcl_FreeParse(&parse); } - /* - * If the source script yielded no instructions (e.g., if it was empty), - * push an empty string as the command's result. - */ - - if (lastCmdIdx >= 0) { + if (lastCmdIdx == -1) { + /* + * Compiling the script yielded no bytecode. The script must be + * all whitespace, comments, and empty commands. Such scripts + * are defined to successfully produce the empty string result, + * so we emit the simple bytecode that makes that happen. + */ + PushStringLiteral(envPtr, ""); + } else { + /* + * We compiled at least one command to bytecode. The routine + * CompileCommandTokens() follows the bytecode of each compiled + * command with an INST_POP, so that stack balance is maintained + * when several commands are in sequence. (The result of each + * command is thrown away before moving on to the next command). + * For the last command compiled, we need to undo that INST_POP + * so that the result of the last command becomes the result of + * the script. These code here removes that trailing INST_POP. + */ envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; envPtr->currStackDepth++; - } else { - PushStringLiteral(envPtr, ""); } #else int lastTopLevelCmdIndex = -1; diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..d4ece74 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} { missing close-brace for variable name missing close-brace for variable name while executing -"set tst $a([winfo name $\{zz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." +"set tst $a([winfo name $\{" (procedure "tstProc" line 4) invoked from within "tstProc"}] -- cgit v0.12 From 6126629e09afa73afc95abe698873234c68c643c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 2 Jul 2013 07:14:59 +0000 Subject: Bug [32afa6e256]: dirent64 check is incorrect in tcl.m4. Thanks to Brian Griffin. --- unix/configure | 2 +- unix/tcl.m4 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index 61c2247..3e04284 100755 --- a/unix/configure +++ b/unix/configure @@ -9619,7 +9619,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include -#include +#include int main () { diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 850e940..bac5ebe 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -2776,7 +2776,7 @@ AC_DEFUN([SC_TCL_64BIT_FLAGS], [ # Now check for auxiliary declarations AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[ AC_TRY_COMPILE([#include -#include ],[struct dirent64 p;], +#include ],[struct dirent64 p;], tcl_cv_struct_dirent64=yes,tcl_cv_struct_dirent64=no)]) if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then AC_DEFINE(HAVE_STRUCT_DIRENT64, 1, [Is 'struct dirent64' in ?]) -- cgit v0.12 From 4fe87442ab9dc726e56daa494f7f60c2cb0efc75 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 2 Jul 2013 07:16:22 +0000 Subject: Don't forget ChangeLog for previous commit --- ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index 10d21d0..e877bd7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-07-02 Jan Nijtmans + + * unix/tcl.m4: Bug [32afa6e256]: dirent64 check is incorrect in tcl.m4 + * unix/configure: (thanks to Brian Griffin) + 2013-06-27 Jan Nijtmans * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs initialized -- cgit v0.12 From 5599b1864958a90b4754b554eadb41722bdc9246 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 2 Jul 2013 10:36:32 +0000 Subject: comment improvements --- generic/tclCompile.c | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6f5ef50..05daabf 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1764,6 +1764,7 @@ CompileCommandTokens( assert (numWords > 0); + /* Determine whether any words of the command require expansion */ for (wordIdx = 0; wordIdx < numWords; wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { @@ -1772,6 +1773,7 @@ CompileCommandTokens( } } + /* Do we know the command word? */ Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); @@ -1791,6 +1793,7 @@ CompileCommandTokens( } } } + /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ /* Pre-Compile */ @@ -2112,7 +2115,22 @@ TclCompileScript( p = next; if (parse.numWords == 0) { - /* TODO: Document justification */ + /* + * The "command" parsed has no words. In this case + * we can skip the rest of the loop body. With no words, + * clearly CompileCommandTokens() has nothing to do. Since + * the parser aggressively sucks up leading comment and white + * space, including newlines, parse.commandStart must be + * pointing at either the end of script, or a command-terminating + * semi-colon. In either case, the TclAdvance*() calls have + * nothing to do. Finally, when no words are parsed, no + * tokens have been allocated at parse.tokenPtr so there's + * also nothing for Tcl_FreeParse() to do. + * + * The advantage of this shortcut is that CompileCommandTokens() + * can be written with an assumption that parse.numWords > 0, + * with the implication the CCT() always generates bytecode. + */ continue; } @@ -2145,7 +2163,7 @@ TclCompileScript( * command is thrown away before moving on to the next command). * For the last command compiled, we need to undo that INST_POP * so that the result of the last command becomes the result of - * the script. These code here removes that trailing INST_POP. + * the script. The code here removes that trailing INST_POP. */ envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; -- cgit v0.12 From 897293c4c13d94223af9ebf03798a5ddcf08dcb6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 3 Jul 2013 08:56:34 +0000 Subject: Fix compiler warning when compiling Cygwin port with -Wwrite-strings --- unix/tclUnixNotfy.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index b87af1b..aacc8d2d 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -96,7 +96,7 @@ typedef struct ThreadSpecificData { * that an event is ready to be processed * by sending this event. */ void *hwnd; /* Messaging window. */ -#else +#else /* !__CYGWIN__ */ Tcl_Condition waitCV; /* Any other thread alerts a notifier that an * event is ready to be processed by signaling * this condition variable. */ @@ -184,9 +184,9 @@ static Tcl_ThreadId notifierThread; */ #ifdef TCL_THREADS -static void NotifierThreadProc(ClientData clientData); +static void NotifierThreadProc(ClientData clientData); #endif -static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); +static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); /* * Import of Windows API when building threaded with Cygwin. @@ -213,14 +213,14 @@ typedef struct { void *hCursor; void *hbrBackground; void *lpszMenuName; - void *lpszClassName; + const void *lpszClassName; } WNDCLASS; extern void __stdcall CloseHandle(void *); extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char, void *); -extern void * __stdcall CreateWindowExW(void *, void *, void *, DWORD, int, - int, int, int, void *, void *, void *, void *); +extern void * __stdcall CreateWindowExW(void *, const void *, const void *, + DWORD, int, int, int, int, void *, void *, void *, void *); extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *); extern unsigned char __stdcall DestroyWindow(void *); extern int __stdcall DispatchMessageW(const MSG *); -- cgit v0.12 From 950488656e09b8da52835a7abe385816f571e607 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 3 Jul 2013 08:59:09 +0000 Subject: =?UTF-8?q?Fix=20compiler=20warning=20when=20compiling=20Itcl=204.?= =?UTF-8?q?0:=20In=20file=20included=20from=20./generic/itcl2TclOO.c:12:0:?= =?UTF-8?q?=20/Tcl/include/tclInt.h:3012:8:=20warning:=20=E2=80=98struct?= =?UTF-8?q?=20addrinfo=E2=80=99=20declared=20inside=20parameter=20list=20[?= =?UTF-8?q?enabled=20by=20default]=20=20=20=20=20=20=20=20=20const=20char?= =?UTF-8?q?=20**errorMsgPtr);=20=20=20=20=20=20=20=20=20^?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclIOSock.c | 4 ++-- generic/tclInt.h | 5 ++--- unix/tclUnixSock.c | 5 +++-- win/tclWinSock.c | 5 +++-- 4 files changed, 10 insertions(+), 9 deletions(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 694501f..7d6c462 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -139,7 +139,7 @@ int TclCreateSocketAddress( Tcl_Interp *interp, /* Interpreter for querying * the desired socket family */ - struct addrinfo **addrlist, /* Socket address list */ + void **addrlist, /* Socket address list */ const char *host, /* Host. NULL implies INADDR_ANY */ int port, /* Port number */ int willBind, /* Is this an address to bind() to or @@ -213,7 +213,7 @@ TclCreateSocketAddress( hints.ai_flags |= AI_PASSIVE; } - result = getaddrinfo(native, portstring, &hints, addrlist); + result = getaddrinfo(native, portstring, &hints, (struct addrinfo **) addrlist); if (host != NULL) { Tcl_DStringFree(&ds); diff --git a/generic/tclInt.h b/generic/tclInt.h index fdd577a..b940225 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3010,9 +3010,8 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, - struct addrinfo **addrlist, - const char *host, int port, int willBind, - const char **errorMsgPtr); + void **addrlist, const char *host, int port, + int willBind, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 528f009..9c3d7eb 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1131,7 +1131,7 @@ Tcl_OpenTcpClient( { TcpState *state; const char *errorMsg = NULL; - struct addrinfo *addrlist = NULL, *myaddrlist = NULL; + void *addrlist = NULL, *myaddrlist = NULL; char channelName[SOCK_CHAN_LENGTH]; /* @@ -1276,7 +1276,8 @@ Tcl_OpenTcpServer( ClientData acceptProcData) /* Data for the callback. */ { int status = 0, sock = -1, reuseaddr = 1, chosenport = 0; - struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */ + void *addrlist = NULL; + struct addrinfo *addrPtr; /* socket address */ TcpState *statePtr = NULL; char channelName[SOCK_CHAN_LENGTH]; const char *errorMsg = NULL; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 4ced0e7..f4d5a90 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1131,9 +1131,10 @@ CreateSocket( int asyncConnect = 0; /* Will be 1 if async connect is in * progress. */ unsigned short chosenport = 0; - struct addrinfo *addrlist = NULL, *addrPtr; + void *addrlist = NULL, *myaddrlist = NULL; + struct addrinfo *addrPtr; /* Socket address to connect to. */ - struct addrinfo *myaddrlist = NULL, *myaddrPtr; + struct addrinfo *myaddrPtr; /* Socket address for our side. */ const char *errorMsg = NULL; SOCKET sock = INVALID_SOCKET; -- cgit v0.12 From 843b98eacf8b17269d37cbc8d6e446dad9fe6f73 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 3 Jul 2013 10:39:50 +0000 Subject: Bug [817249]: bring tclXtNotify.c up to date with Tcl_SetNotifier() change --- ChangeLog | 5 +++++ unix/tclXtNotify.c | 38 +++++++++++++++++++++----------------- 2 files changed, 26 insertions(+), 17 deletions(-) diff --git a/ChangeLog b/ChangeLog index e877bd7..97509e2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-07-03 Jan Nijtmans + + * unix/tclXtNotify.c: Bug [817249]: bring tclXtNotify.c up to date with + Tcl_SetNotifier() change. + 2013-07-02 Jan Nijtmans * unix/tcl.m4: Bug [32afa6e256]: dirent64 check is incorrect in tcl.m4 diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c index 6a11c0d..b2d1f4d 100644 --- a/unix/tclXtNotify.c +++ b/unix/tclXtNotify.c @@ -74,13 +74,12 @@ static int initialized = 0; */ static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); -static void FileProc(caddr_t clientData, int *source, +static void FileProc(XtPointer clientData, int *source, XtInputId *id); -void InitNotifier(void); static void NotifierExitHandler(ClientData clientData); -static void TimerProc(caddr_t clientData, XtIntervalId *id); +static void TimerProc(XtPointer clientData, XtIntervalId *id); static void CreateFileHandler(int fd, int mask, - Tcl_FileProc * proc, ClientData clientData); + Tcl_FileProc *proc, ClientData clientData); static void DeleteFileHandler(int fd); static void SetTimer(Tcl_Time * timePtr); static int WaitForEvent(Tcl_Time * timePtr); @@ -89,7 +88,8 @@ static int WaitForEvent(Tcl_Time * timePtr); * Functions defined in this file for use by users of the Xt Notifier: */ -EXTERN XtAppContext TclSetAppContext(XtAppContext ctx); +MODULE_SCOPE void InitNotifier(void); +MODULE_SCOPE XtAppContext TclSetAppContext(XtAppContext ctx); /* *---------------------------------------------------------------------- @@ -178,7 +178,7 @@ TclSetAppContext( void InitNotifier(void) { - Tcl_NotifierProcs notifier; + Tcl_NotifierProcs np; /* * Only reinitialize if we are not in exit handling. The notifier can get @@ -190,11 +190,15 @@ InitNotifier(void) return; } - notifier.createFileHandlerProc = CreateFileHandler; - notifier.deleteFileHandlerProc = DeleteFileHandler; - notifier.setTimerProc = SetTimer; - notifier.waitForEventProc = WaitForEvent; - Tcl_SetNotifier(¬ifier); + np.createFileHandlerProc = CreateFileHandler; + np.deleteFileHandlerProc = DeleteFileHandler; + np.setTimerProc = SetTimer; + np.waitForEventProc = WaitForEvent; + np.initNotifierProc = Tcl_InitNotifier; + np.finalizeNotifierProc = Tcl_FinalizeNotifier; + np.alertNotifierProc = Tcl_AlertNotifier; + np.serviceModeHookProc = Tcl_ServiceModeHook; + Tcl_SetNotifier(&np); /* * DO NOT create the application context yet; doing so would prevent @@ -202,7 +206,7 @@ InitNotifier(void) */ initialized = 1; - memset(¬ifier, 0, sizeof(notifier)); + memset(&np, 0, sizeof(np)); Tcl_CreateExitHandler(NotifierExitHandler, NULL); } @@ -298,7 +302,7 @@ SetTimer( static void TimerProc( - caddr_t data, /* Not used. */ + XtPointer clientData, /* Not used. */ XtIntervalId *id) { if (*id != notifier.currentTimeout) { @@ -372,7 +376,7 @@ CreateFileHandler( if (mask & TCL_READABLE) { if (!(filePtr->mask & TCL_READABLE)) { filePtr->read = XtAppAddInput(notifier.appContext, fd, - XtInputReadMask, FileProc, filePtr); + INT2PTR(XtInputReadMask), FileProc, filePtr); } } else { if (filePtr->mask & TCL_READABLE) { @@ -382,7 +386,7 @@ CreateFileHandler( if (mask & TCL_WRITABLE) { if (!(filePtr->mask & TCL_WRITABLE)) { filePtr->write = XtAppAddInput(notifier.appContext, fd, - XtInputWriteMask, FileProc, filePtr); + INT2PTR(XtInputWriteMask), FileProc, filePtr); } } else { if (filePtr->mask & TCL_WRITABLE) { @@ -392,7 +396,7 @@ CreateFileHandler( if (mask & TCL_EXCEPTION) { if (!(filePtr->mask & TCL_EXCEPTION)) { filePtr->except = XtAppAddInput(notifier.appContext, fd, - XtInputExceptMask, FileProc, filePtr); + INT2PTR(XtInputExceptMask), FileProc, filePtr); } } else { if (filePtr->mask & TCL_EXCEPTION) { @@ -485,7 +489,7 @@ DeleteFileHandler( static void FileProc( - caddr_t clientData, + XtPointer clientData, int *fd, XtInputId *id) { -- cgit v0.12 From e27613d051d663dca9388efda64d8cdf2263ba1d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 5 Jul 2013 14:02:59 +0000 Subject: Allow successfull compilation, even if Tcl_GetErrorLine/Tcl_SetErrorLine are redefined as macros. --- generic/tclResult.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclResult.c b/generic/tclResult.c index 014ea1b..2f2563a 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1112,6 +1112,7 @@ Tcl_SetObjErrorCode( *---------------------------------------------------------------------- */ +#undef Tcl_GetErrorLine int Tcl_GetErrorLine( Tcl_Interp *interp) @@ -1129,6 +1130,7 @@ Tcl_GetErrorLine( *---------------------------------------------------------------------- */ +#undef Tcl_SetErrorLine void Tcl_SetErrorLine( Tcl_Interp *interp, -- cgit v0.12 From db6da56aeed8fd3ef50c82f06e1a488fb5d57e3b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 5 Jul 2013 14:04:03 +0000 Subject: CONST -> const in one place --- generic/tclConfig.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclConfig.c b/generic/tclConfig.c index e5acf5e..2fb3e92 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -211,7 +211,7 @@ QueryConfigObjCmd( }; Tcl_DString conv; Tcl_Encoding venc = NULL; - CONST char *value; + const char *value; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?"); -- cgit v0.12 From eca681b804474b740e51f8be8a67a7b2ceea6e13 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 5 Jul 2013 14:52:07 +0000 Subject: Use X11/Xlib.h for checking where X11 can be found in stead of X11/XIntrinsic.h. Suggested by Pietro Cerutti. (Backported from tclconfig) --- unix/tcl.m4 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/tcl.m4 b/unix/tcl.m4 index bac5ebe..cdc5f99 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -2386,9 +2386,9 @@ AC_DEFUN([SC_PATH_X], [ not_really_there="" if test "$no_x" = ""; then if test "$x_includes" = ""; then - AC_TRY_CPP([#include ], , not_really_there="yes") + AC_TRY_CPP([#include ], , not_really_there="yes") else - if test ! -r $x_includes/X11/Intrinsic.h; then + if test ! -r $x_includes/X11/Xlib.h; then not_really_there="yes" fi fi @@ -2396,11 +2396,11 @@ AC_DEFUN([SC_PATH_X], [ if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then AC_MSG_CHECKING([for X11 header files]) found_xincludes="no" - AC_TRY_CPP([#include ], found_xincludes="yes", found_xincludes="no") + AC_TRY_CPP([#include ], found_xincludes="yes", found_xincludes="no") if test "$found_xincludes" = "no"; then dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include" for i in $dirs ; do - if test -r $i/X11/Intrinsic.h; then + if test -r $i/X11/Xlib.h; then AC_MSG_RESULT([$i]) XINCLUDES=" -I$i" found_xincludes="yes" -- cgit v0.12 From a0e82d9b9595aa285fde27fda9722e8bbab3cd4f Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 6 Jul 2013 22:22:01 +0000 Subject: http://www.iana.org/time-zones/repository/releases/tzdata2013d.tar.gz --- ChangeLog | 10 ++ library/tzdata/Africa/Casablanca | 4 +- library/tzdata/America/Asuncion | 173 ++++++++++++++++----------------- library/tzdata/Antarctica/Macquarie | 9 +- library/tzdata/Asia/Gaza | 189 ++++++++++++++++++++++++++++++++++-- library/tzdata/Asia/Hebron | 185 +++++++++++++++++++++++++++++++++-- library/tzdata/Asia/Jerusalem | 178 ++++++++++++++++----------------- 7 files changed, 551 insertions(+), 197 deletions(-) diff --git a/ChangeLog b/ChangeLog index 97509e2..71015ed 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2013-07-05 Kevin B. Kenny + + * library/tzdata/Africa/Casablanca: + * library/tzdata/America/Asuncion: + * library/tzdata/Antarctica/Macquarie: + * library/tzdata/Asia/Gaza: + * library/tzdata/Asia/Hebron: + * library/tzdata/Asia/Jerusalem: + http://www.iana.org/time-zones/repository/releases/tzdata2013d.tar.gz + 2013-07-03 Jan Nijtmans * unix/tclXtNotify.c: Bug [817249]: bring tclXtNotify.c up to date with diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 74b767a..757007c 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -34,8 +34,8 @@ set TZData(:Africa/Casablanca) { {1345428000 3600 1 WEST} {1348970400 0 0 WET} {1367114400 3600 1 WEST} - {1373335200 0 0 WET} - {1375927200 3600 1 WEST} + {1373162400 0 0 WET} + {1376100000 3600 1 WEST} {1380420000 0 0 WET} {1398564000 3600 1 WEST} {1404007200 0 0 WET} diff --git a/library/tzdata/America/Asuncion b/library/tzdata/America/Asuncion index d530193..9ea30da 100644 --- a/library/tzdata/America/Asuncion +++ b/library/tzdata/America/Asuncion @@ -83,178 +83,177 @@ set TZData(:America/Asuncion) { {1333854000 -14400 0 PYT} {1349582400 -10800 1 PYST} {1364094000 -14400 0 PYT} - {1365912000 -14400 0 PYT} {1381032000 -10800 1 PYST} - {1397358000 -14400 0 PYT} + {1395543600 -14400 0 PYT} {1412481600 -10800 1 PYST} - {1428807600 -14400 0 PYT} + {1426993200 -14400 0 PYT} {1443931200 -10800 1 PYST} - {1460257200 -14400 0 PYT} + {1459047600 -14400 0 PYT} {1475380800 -10800 1 PYST} - {1491706800 -14400 0 PYT} + {1490497200 -14400 0 PYT} {1506830400 -10800 1 PYST} - {1523156400 -14400 0 PYT} + {1521946800 -14400 0 PYT} {1538884800 -10800 1 PYST} - {1555210800 -14400 0 PYT} + {1553396400 -14400 0 PYT} {1570334400 -10800 1 PYST} - {1586660400 -14400 0 PYT} + {1584846000 -14400 0 PYT} {1601784000 -10800 1 PYST} - {1618110000 -14400 0 PYT} + {1616900400 -14400 0 PYT} {1633233600 -10800 1 PYST} - {1649559600 -14400 0 PYT} + {1648350000 -14400 0 PYT} {1664683200 -10800 1 PYST} - {1681009200 -14400 0 PYT} + {1679799600 -14400 0 PYT} {1696132800 -10800 1 PYST} - {1713063600 -14400 0 PYT} + {1711249200 -14400 0 PYT} {1728187200 -10800 1 PYST} - {1744513200 -14400 0 PYT} + {1742698800 -14400 0 PYT} {1759636800 -10800 1 PYST} - {1775962800 -14400 0 PYT} + {1774148400 -14400 0 PYT} {1791086400 -10800 1 PYST} - {1807412400 -14400 0 PYT} + {1806202800 -14400 0 PYT} {1822536000 -10800 1 PYST} - {1838862000 -14400 0 PYT} + {1837652400 -14400 0 PYT} {1853985600 -10800 1 PYST} - {1870311600 -14400 0 PYT} + {1869102000 -14400 0 PYT} {1886040000 -10800 1 PYST} - {1902366000 -14400 0 PYT} + {1900551600 -14400 0 PYT} {1917489600 -10800 1 PYST} - {1933815600 -14400 0 PYT} + {1932001200 -14400 0 PYT} {1948939200 -10800 1 PYST} - {1965265200 -14400 0 PYT} + {1964055600 -14400 0 PYT} {1980388800 -10800 1 PYST} - {1996714800 -14400 0 PYT} + {1995505200 -14400 0 PYT} {2011838400 -10800 1 PYST} - {2028164400 -14400 0 PYT} + {2026954800 -14400 0 PYT} {2043288000 -10800 1 PYST} - {2059614000 -14400 0 PYT} + {2058404400 -14400 0 PYT} {2075342400 -10800 1 PYST} - {2091668400 -14400 0 PYT} + {2089854000 -14400 0 PYT} {2106792000 -10800 1 PYST} - {2123118000 -14400 0 PYT} + {2121303600 -14400 0 PYT} {2138241600 -10800 1 PYST} - {2154567600 -14400 0 PYT} + {2153358000 -14400 0 PYT} {2169691200 -10800 1 PYST} - {2186017200 -14400 0 PYT} + {2184807600 -14400 0 PYT} {2201140800 -10800 1 PYST} - {2217466800 -14400 0 PYT} + {2216257200 -14400 0 PYT} {2233195200 -10800 1 PYST} - {2249521200 -14400 0 PYT} + {2247706800 -14400 0 PYT} {2264644800 -10800 1 PYST} - {2280970800 -14400 0 PYT} + {2279156400 -14400 0 PYT} {2296094400 -10800 1 PYST} - {2312420400 -14400 0 PYT} + {2310606000 -14400 0 PYT} {2327544000 -10800 1 PYST} - {2343870000 -14400 0 PYT} + {2342660400 -14400 0 PYT} {2358993600 -10800 1 PYST} - {2375319600 -14400 0 PYT} + {2374110000 -14400 0 PYT} {2390443200 -10800 1 PYST} - {2406769200 -14400 0 PYT} + {2405559600 -14400 0 PYT} {2422497600 -10800 1 PYST} - {2438823600 -14400 0 PYT} + {2437009200 -14400 0 PYT} {2453947200 -10800 1 PYST} - {2470273200 -14400 0 PYT} + {2468458800 -14400 0 PYT} {2485396800 -10800 1 PYST} - {2501722800 -14400 0 PYT} + {2500513200 -14400 0 PYT} {2516846400 -10800 1 PYST} - {2533172400 -14400 0 PYT} + {2531962800 -14400 0 PYT} {2548296000 -10800 1 PYST} - {2564622000 -14400 0 PYT} + {2563412400 -14400 0 PYT} {2579745600 -10800 1 PYST} - {2596676400 -14400 0 PYT} + {2594862000 -14400 0 PYT} {2611800000 -10800 1 PYST} - {2628126000 -14400 0 PYT} + {2626311600 -14400 0 PYT} {2643249600 -10800 1 PYST} - {2659575600 -14400 0 PYT} + {2657761200 -14400 0 PYT} {2674699200 -10800 1 PYST} - {2691025200 -14400 0 PYT} + {2689815600 -14400 0 PYT} {2706148800 -10800 1 PYST} - {2722474800 -14400 0 PYT} + {2721265200 -14400 0 PYT} {2737598400 -10800 1 PYST} - {2753924400 -14400 0 PYT} + {2752714800 -14400 0 PYT} {2769652800 -10800 1 PYST} - {2785978800 -14400 0 PYT} + {2784164400 -14400 0 PYT} {2801102400 -10800 1 PYST} - {2817428400 -14400 0 PYT} + {2815614000 -14400 0 PYT} {2832552000 -10800 1 PYST} - {2848878000 -14400 0 PYT} + {2847668400 -14400 0 PYT} {2864001600 -10800 1 PYST} - {2880327600 -14400 0 PYT} + {2879118000 -14400 0 PYT} {2895451200 -10800 1 PYST} - {2911777200 -14400 0 PYT} + {2910567600 -14400 0 PYT} {2926900800 -10800 1 PYST} - {2943226800 -14400 0 PYT} + {2942017200 -14400 0 PYT} {2958955200 -10800 1 PYST} - {2975281200 -14400 0 PYT} + {2973466800 -14400 0 PYT} {2990404800 -10800 1 PYST} - {3006730800 -14400 0 PYT} + {3004916400 -14400 0 PYT} {3021854400 -10800 1 PYST} - {3038180400 -14400 0 PYT} + {3036970800 -14400 0 PYT} {3053304000 -10800 1 PYST} - {3069630000 -14400 0 PYT} + {3068420400 -14400 0 PYT} {3084753600 -10800 1 PYST} - {3101079600 -14400 0 PYT} + {3099870000 -14400 0 PYT} {3116808000 -10800 1 PYST} - {3133134000 -14400 0 PYT} + {3131319600 -14400 0 PYT} {3148257600 -10800 1 PYST} - {3164583600 -14400 0 PYT} + {3162769200 -14400 0 PYT} {3179707200 -10800 1 PYST} - {3196033200 -14400 0 PYT} + {3194218800 -14400 0 PYT} {3211156800 -10800 1 PYST} - {3227482800 -14400 0 PYT} + {3226273200 -14400 0 PYT} {3242606400 -10800 1 PYST} - {3258932400 -14400 0 PYT} + {3257722800 -14400 0 PYT} {3274056000 -10800 1 PYST} - {3290382000 -14400 0 PYT} + {3289172400 -14400 0 PYT} {3306110400 -10800 1 PYST} - {3322436400 -14400 0 PYT} + {3320622000 -14400 0 PYT} {3337560000 -10800 1 PYST} - {3353886000 -14400 0 PYT} + {3352071600 -14400 0 PYT} {3369009600 -10800 1 PYST} - {3385335600 -14400 0 PYT} + {3384126000 -14400 0 PYT} {3400459200 -10800 1 PYST} - {3416785200 -14400 0 PYT} + {3415575600 -14400 0 PYT} {3431908800 -10800 1 PYST} - {3448234800 -14400 0 PYT} + {3447025200 -14400 0 PYT} {3463358400 -10800 1 PYST} - {3480289200 -14400 0 PYT} + {3478474800 -14400 0 PYT} {3495412800 -10800 1 PYST} - {3511738800 -14400 0 PYT} + {3509924400 -14400 0 PYT} {3526862400 -10800 1 PYST} - {3543188400 -14400 0 PYT} + {3541374000 -14400 0 PYT} {3558312000 -10800 1 PYST} - {3574638000 -14400 0 PYT} + {3573428400 -14400 0 PYT} {3589761600 -10800 1 PYST} - {3606087600 -14400 0 PYT} + {3604878000 -14400 0 PYT} {3621211200 -10800 1 PYST} - {3637537200 -14400 0 PYT} + {3636327600 -14400 0 PYT} {3653265600 -10800 1 PYST} - {3669591600 -14400 0 PYT} + {3667777200 -14400 0 PYT} {3684715200 -10800 1 PYST} - {3701041200 -14400 0 PYT} + {3699226800 -14400 0 PYT} {3716164800 -10800 1 PYST} - {3732490800 -14400 0 PYT} + {3731281200 -14400 0 PYT} {3747614400 -10800 1 PYST} - {3763940400 -14400 0 PYT} + {3762730800 -14400 0 PYT} {3779064000 -10800 1 PYST} - {3795390000 -14400 0 PYT} + {3794180400 -14400 0 PYT} {3810513600 -10800 1 PYST} - {3826839600 -14400 0 PYT} + {3825630000 -14400 0 PYT} {3842568000 -10800 1 PYST} - {3858894000 -14400 0 PYT} + {3857079600 -14400 0 PYT} {3874017600 -10800 1 PYST} - {3890343600 -14400 0 PYT} + {3888529200 -14400 0 PYT} {3905467200 -10800 1 PYST} - {3921793200 -14400 0 PYT} + {3920583600 -14400 0 PYT} {3936916800 -10800 1 PYST} - {3953242800 -14400 0 PYT} + {3952033200 -14400 0 PYT} {3968366400 -10800 1 PYST} - {3984692400 -14400 0 PYT} + {3983482800 -14400 0 PYT} {4000420800 -10800 1 PYST} - {4016746800 -14400 0 PYT} + {4014932400 -14400 0 PYT} {4031870400 -10800 1 PYST} - {4048196400 -14400 0 PYT} + {4046382000 -14400 0 PYT} {4063320000 -10800 1 PYST} - {4079646000 -14400 0 PYT} + {4077831600 -14400 0 PYT} {4094769600 -10800 1 PYST} } diff --git a/library/tzdata/Antarctica/Macquarie b/library/tzdata/Antarctica/Macquarie index 9877ee8..bd5cf8a 100644 --- a/library/tzdata/Antarctica/Macquarie +++ b/library/tzdata/Antarctica/Macquarie @@ -2,16 +2,11 @@ set TZData(:Antarctica/Macquarie) { {-9223372036854775808 0 0 zzz} - {-1861920000 36000 0 EST} + {-2214259200 36000 0 EST} {-1680508800 39600 1 EST} {-1669892400 39600 0 EST} {-1665392400 36000 0 EST} - {-883641600 39600 1 EST} - {-876128400 36000 0 EST} - {-860400000 39600 1 EST} - {-844678800 36000 0 EST} - {-828345600 39600 1 EST} - {-813229200 36000 0 EST} + {-1601719200 0 0 zzz} {-94730400 36000 0 EST} {-71136000 39600 1 EST} {-55411200 36000 0 EST} diff --git a/library/tzdata/Asia/Gaza b/library/tzdata/Asia/Gaza index 43e1847..a0636e2 100644 --- a/library/tzdata/Asia/Gaza +++ b/library/tzdata/Asia/Gaza @@ -88,14 +88,191 @@ set TZData(:Asia/Gaza) { {1158872400 7200 0 EET} {1175378400 10800 1 EEST} {1189638000 7200 0 EET} - {1207000800 10800 1 EEST} - {1219957200 7200 0 EET} + {1206655200 10800 1 EEST} + {1219960800 7200 0 EET} + {1220220000 7200 0 EET} {1238104800 10800 1 EEST} - {1252018800 7200 0 EET} - {1269640860 10800 1 EEST} + {1252015200 7200 0 EET} + {1262296800 7200 0 EET} + {1269640860 10800 0 EEST} {1281474000 7200 0 EET} - {1301738460 10800 1 EEST} - {1312146000 7200 0 EET} + {1301608860 10800 1 EEST} + {1312149600 7200 0 EET} + {1325368800 7200 0 EET} {1333058400 10800 1 EEST} {1348178400 7200 0 EET} + {1364508000 10800 1 EEST} + {1380232800 7200 0 EET} + {1395957600 10800 1 EEST} + {1411682400 7200 0 EET} + {1427407200 10800 1 EEST} + {1443132000 7200 0 EET} + {1459461600 10800 1 EEST} + {1474581600 7200 0 EET} + {1490911200 10800 1 EEST} + {1506031200 7200 0 EET} + {1522360800 10800 1 EEST} + {1537480800 7200 0 EET} + {1553810400 10800 1 EEST} + {1569535200 7200 0 EET} + {1585260000 10800 1 EEST} + {1600984800 7200 0 EET} + {1616709600 10800 1 EEST} + {1632434400 7200 0 EET} + {1648764000 10800 1 EEST} + {1663884000 7200 0 EET} + {1680213600 10800 1 EEST} + {1695333600 7200 0 EET} + {1711663200 10800 1 EEST} + {1727388000 7200 0 EET} + {1743112800 10800 1 EEST} + {1758837600 7200 0 EET} + {1774562400 10800 1 EEST} + {1790287200 7200 0 EET} + {1806012000 10800 1 EEST} + {1821736800 7200 0 EET} + {1838066400 10800 1 EEST} + {1853186400 7200 0 EET} + {1869516000 10800 1 EEST} + {1884636000 7200 0 EET} + {1900965600 10800 1 EEST} + {1916690400 7200 0 EET} + {1932415200 10800 1 EEST} + {1948140000 7200 0 EET} + {1963864800 10800 1 EEST} + {1979589600 7200 0 EET} + {1995919200 10800 1 EEST} + {2011039200 7200 0 EET} + {2027368800 10800 1 EEST} + {2042488800 7200 0 EET} + {2058818400 10800 1 EEST} + {2073938400 7200 0 EET} + {2090268000 10800 1 EEST} + {2105992800 7200 0 EET} + {2121717600 10800 1 EEST} + {2137442400 7200 0 EET} + {2153167200 10800 1 EEST} + {2168892000 7200 0 EET} + {2185221600 10800 1 EEST} + {2200341600 7200 0 EET} + {2216671200 10800 1 EEST} + {2231791200 7200 0 EET} + {2248120800 10800 1 EEST} + {2263845600 7200 0 EET} + {2279570400 10800 1 EEST} + {2295295200 7200 0 EET} + {2311020000 10800 1 EEST} + {2326744800 7200 0 EET} + {2343074400 10800 1 EEST} + {2358194400 7200 0 EET} + {2374524000 10800 1 EEST} + {2389644000 7200 0 EET} + {2405973600 10800 1 EEST} + {2421093600 7200 0 EET} + {2437423200 10800 1 EEST} + {2453148000 7200 0 EET} + {2468872800 10800 1 EEST} + {2484597600 7200 0 EET} + {2500322400 10800 1 EEST} + {2516047200 7200 0 EET} + {2532376800 10800 1 EEST} + {2547496800 7200 0 EET} + {2563826400 10800 1 EEST} + {2578946400 7200 0 EET} + {2595276000 10800 1 EEST} + {2611000800 7200 0 EET} + {2626725600 10800 1 EEST} + {2642450400 7200 0 EET} + {2658175200 10800 1 EEST} + {2673900000 7200 0 EET} + {2689624800 10800 1 EEST} + {2705349600 7200 0 EET} + {2721679200 10800 1 EEST} + {2736799200 7200 0 EET} + {2753128800 10800 1 EEST} + {2768248800 7200 0 EET} + {2784578400 10800 1 EEST} + {2800303200 7200 0 EET} + {2816028000 10800 1 EEST} + {2831752800 7200 0 EET} + {2847477600 10800 1 EEST} + {2863202400 7200 0 EET} + {2879532000 10800 1 EEST} + {2894652000 7200 0 EET} + {2910981600 10800 1 EEST} + {2926101600 7200 0 EET} + {2942431200 10800 1 EEST} + {2957551200 7200 0 EET} + {2973880800 10800 1 EEST} + {2989605600 7200 0 EET} + {3005330400 10800 1 EEST} + {3021055200 7200 0 EET} + {3036780000 10800 1 EEST} + {3052504800 7200 0 EET} + {3068834400 10800 1 EEST} + {3083954400 7200 0 EET} + {3100284000 10800 1 EEST} + {3115404000 7200 0 EET} + {3131733600 10800 1 EEST} + {3147458400 7200 0 EET} + {3163183200 10800 1 EEST} + {3178908000 7200 0 EET} + {3194632800 10800 1 EEST} + {3210357600 7200 0 EET} + {3226687200 10800 1 EEST} + {3241807200 7200 0 EET} + {3258136800 10800 1 EEST} + {3273256800 7200 0 EET} + {3289586400 10800 1 EEST} + {3304706400 7200 0 EET} + {3321036000 10800 1 EEST} + {3336760800 7200 0 EET} + {3352485600 10800 1 EEST} + {3368210400 7200 0 EET} + {3383935200 10800 1 EEST} + {3399660000 7200 0 EET} + {3415989600 10800 1 EEST} + {3431109600 7200 0 EET} + {3447439200 10800 1 EEST} + {3462559200 7200 0 EET} + {3478888800 10800 1 EEST} + {3494613600 7200 0 EET} + {3510338400 10800 1 EEST} + {3526063200 7200 0 EET} + {3541788000 10800 1 EEST} + {3557512800 7200 0 EET} + {3573237600 10800 1 EEST} + {3588962400 7200 0 EET} + {3605292000 10800 1 EEST} + {3620412000 7200 0 EET} + {3636741600 10800 1 EEST} + {3651861600 7200 0 EET} + {3668191200 10800 1 EEST} + {3683916000 7200 0 EET} + {3699640800 10800 1 EEST} + {3715365600 7200 0 EET} + {3731090400 10800 1 EEST} + {3746815200 7200 0 EET} + {3763144800 10800 1 EEST} + {3778264800 7200 0 EET} + {3794594400 10800 1 EEST} + {3809714400 7200 0 EET} + {3826044000 10800 1 EEST} + {3841164000 7200 0 EET} + {3857493600 10800 1 EEST} + {3873218400 7200 0 EET} + {3888943200 10800 1 EEST} + {3904668000 7200 0 EET} + {3920392800 10800 1 EEST} + {3936117600 7200 0 EET} + {3952447200 10800 1 EEST} + {3967567200 7200 0 EET} + {3983896800 10800 1 EEST} + {3999016800 7200 0 EET} + {4015346400 10800 1 EEST} + {4031071200 7200 0 EET} + {4046796000 10800 1 EEST} + {4062520800 7200 0 EET} + {4078245600 10800 1 EEST} + {4093970400 7200 0 EET} } diff --git a/library/tzdata/Asia/Hebron b/library/tzdata/Asia/Hebron index 98bb353..a8a9019 100644 --- a/library/tzdata/Asia/Hebron +++ b/library/tzdata/Asia/Hebron @@ -88,17 +88,190 @@ set TZData(:Asia/Hebron) { {1158872400 7200 0 EET} {1175378400 10800 1 EEST} {1189638000 7200 0 EET} - {1207000800 10800 1 EEST} - {1217541600 10800 1 EEST} + {1206655200 10800 1 EEST} {1220216400 7200 0 EET} {1238104800 10800 1 EEST} - {1252018800 7200 0 EET} - {1269640860 10800 1 EEST} + {1252015200 7200 0 EET} + {1269554400 10800 1 EEST} {1281474000 7200 0 EET} - {1301652060 10800 1 EEST} + {1301608860 10800 1 EEST} {1312146000 7200 0 EET} {1314655200 10800 1 EEST} - {1317340800 7200 0 EET} + {1317330000 7200 0 EET} {1333058400 10800 1 EEST} {1348178400 7200 0 EET} + {1364508000 10800 1 EEST} + {1380232800 7200 0 EET} + {1395957600 10800 1 EEST} + {1411682400 7200 0 EET} + {1427407200 10800 1 EEST} + {1443132000 7200 0 EET} + {1459461600 10800 1 EEST} + {1474581600 7200 0 EET} + {1490911200 10800 1 EEST} + {1506031200 7200 0 EET} + {1522360800 10800 1 EEST} + {1537480800 7200 0 EET} + {1553810400 10800 1 EEST} + {1569535200 7200 0 EET} + {1585260000 10800 1 EEST} + {1600984800 7200 0 EET} + {1616709600 10800 1 EEST} + {1632434400 7200 0 EET} + {1648764000 10800 1 EEST} + {1663884000 7200 0 EET} + {1680213600 10800 1 EEST} + {1695333600 7200 0 EET} + {1711663200 10800 1 EEST} + {1727388000 7200 0 EET} + {1743112800 10800 1 EEST} + {1758837600 7200 0 EET} + {1774562400 10800 1 EEST} + {1790287200 7200 0 EET} + {1806012000 10800 1 EEST} + {1821736800 7200 0 EET} + {1838066400 10800 1 EEST} + {1853186400 7200 0 EET} + {1869516000 10800 1 EEST} + {1884636000 7200 0 EET} + {1900965600 10800 1 EEST} + {1916690400 7200 0 EET} + {1932415200 10800 1 EEST} + {1948140000 7200 0 EET} + {1963864800 10800 1 EEST} + {1979589600 7200 0 EET} + {1995919200 10800 1 EEST} + {2011039200 7200 0 EET} + {2027368800 10800 1 EEST} + {2042488800 7200 0 EET} + {2058818400 10800 1 EEST} + {2073938400 7200 0 EET} + {2090268000 10800 1 EEST} + {2105992800 7200 0 EET} + {2121717600 10800 1 EEST} + {2137442400 7200 0 EET} + {2153167200 10800 1 EEST} + {2168892000 7200 0 EET} + {2185221600 10800 1 EEST} + {2200341600 7200 0 EET} + {2216671200 10800 1 EEST} + {2231791200 7200 0 EET} + {2248120800 10800 1 EEST} + {2263845600 7200 0 EET} + {2279570400 10800 1 EEST} + {2295295200 7200 0 EET} + {2311020000 10800 1 EEST} + {2326744800 7200 0 EET} + {2343074400 10800 1 EEST} + {2358194400 7200 0 EET} + {2374524000 10800 1 EEST} + {2389644000 7200 0 EET} + {2405973600 10800 1 EEST} + {2421093600 7200 0 EET} + {2437423200 10800 1 EEST} + {2453148000 7200 0 EET} + {2468872800 10800 1 EEST} + {2484597600 7200 0 EET} + {2500322400 10800 1 EEST} + {2516047200 7200 0 EET} + {2532376800 10800 1 EEST} + {2547496800 7200 0 EET} + {2563826400 10800 1 EEST} + {2578946400 7200 0 EET} + {2595276000 10800 1 EEST} + {2611000800 7200 0 EET} + {2626725600 10800 1 EEST} + {2642450400 7200 0 EET} + {2658175200 10800 1 EEST} + {2673900000 7200 0 EET} + {2689624800 10800 1 EEST} + {2705349600 7200 0 EET} + {2721679200 10800 1 EEST} + {2736799200 7200 0 EET} + {2753128800 10800 1 EEST} + {2768248800 7200 0 EET} + {2784578400 10800 1 EEST} + {2800303200 7200 0 EET} + {2816028000 10800 1 EEST} + {2831752800 7200 0 EET} + {2847477600 10800 1 EEST} + {2863202400 7200 0 EET} + {2879532000 10800 1 EEST} + {2894652000 7200 0 EET} + {2910981600 10800 1 EEST} + {2926101600 7200 0 EET} + {2942431200 10800 1 EEST} + {2957551200 7200 0 EET} + {2973880800 10800 1 EEST} + {2989605600 7200 0 EET} + {3005330400 10800 1 EEST} + {3021055200 7200 0 EET} + {3036780000 10800 1 EEST} + {3052504800 7200 0 EET} + {3068834400 10800 1 EEST} + {3083954400 7200 0 EET} + {3100284000 10800 1 EEST} + {3115404000 7200 0 EET} + {3131733600 10800 1 EEST} + {3147458400 7200 0 EET} + {3163183200 10800 1 EEST} + {3178908000 7200 0 EET} + {3194632800 10800 1 EEST} + {3210357600 7200 0 EET} + {3226687200 10800 1 EEST} + {3241807200 7200 0 EET} + {3258136800 10800 1 EEST} + {3273256800 7200 0 EET} + {3289586400 10800 1 EEST} + {3304706400 7200 0 EET} + {3321036000 10800 1 EEST} + {3336760800 7200 0 EET} + {3352485600 10800 1 EEST} + {3368210400 7200 0 EET} + {3383935200 10800 1 EEST} + {3399660000 7200 0 EET} + {3415989600 10800 1 EEST} + {3431109600 7200 0 EET} + {3447439200 10800 1 EEST} + {3462559200 7200 0 EET} + {3478888800 10800 1 EEST} + {3494613600 7200 0 EET} + {3510338400 10800 1 EEST} + {3526063200 7200 0 EET} + {3541788000 10800 1 EEST} + {3557512800 7200 0 EET} + {3573237600 10800 1 EEST} + {3588962400 7200 0 EET} + {3605292000 10800 1 EEST} + {3620412000 7200 0 EET} + {3636741600 10800 1 EEST} + {3651861600 7200 0 EET} + {3668191200 10800 1 EEST} + {3683916000 7200 0 EET} + {3699640800 10800 1 EEST} + {3715365600 7200 0 EET} + {3731090400 10800 1 EEST} + {3746815200 7200 0 EET} + {3763144800 10800 1 EEST} + {3778264800 7200 0 EET} + {3794594400 10800 1 EEST} + {3809714400 7200 0 EET} + {3826044000 10800 1 EEST} + {3841164000 7200 0 EET} + {3857493600 10800 1 EEST} + {3873218400 7200 0 EET} + {3888943200 10800 1 EEST} + {3904668000 7200 0 EET} + {3920392800 10800 1 EEST} + {3936117600 7200 0 EET} + {3952447200 10800 1 EEST} + {3967567200 7200 0 EET} + {3983896800 10800 1 EEST} + {3999016800 7200 0 EET} + {4015346400 10800 1 EEST} + {4031071200 7200 0 EET} + {4046796000 10800 1 EEST} + {4062520800 7200 0 EET} + {4078245600 10800 1 EEST} + {4093970400 7200 0 EET} } diff --git a/library/tzdata/Asia/Jerusalem b/library/tzdata/Asia/Jerusalem index 613eadd..7662680 100644 --- a/library/tzdata/Asia/Jerusalem +++ b/library/tzdata/Asia/Jerusalem @@ -1,8 +1,8 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Asia/Jerusalem) { - {-9223372036854775808 8456 0 LMT} - {-2840149256 8440 0 JMT} + {-9223372036854775808 8454 0 LMT} + {-2840149254 8440 0 JMT} {-1641003640 7200 0 IST} {-933645600 10800 1 IDT} {-857358000 7200 0 IST} @@ -96,177 +96,177 @@ set TZData(:Asia/Jerusalem) { {1333065600 10800 1 IDT} {1348354800 7200 0 IST} {1364515200 10800 1 IDT} - {1381014000 7200 0 IST} + {1382828400 7200 0 IST} {1395964800 10800 1 IDT} - {1412463600 7200 0 IST} + {1414278000 7200 0 IST} {1427414400 10800 1 IDT} - {1443913200 7200 0 IST} + {1445727600 7200 0 IST} {1458864000 10800 1 IDT} - {1475362800 7200 0 IST} + {1477782000 7200 0 IST} {1490313600 10800 1 IDT} - {1507417200 7200 0 IST} + {1509231600 7200 0 IST} {1521763200 10800 1 IDT} - {1538866800 7200 0 IST} + {1540681200 7200 0 IST} {1553817600 10800 1 IDT} - {1570316400 7200 0 IST} + {1572130800 7200 0 IST} {1585267200 10800 1 IDT} - {1601766000 7200 0 IST} + {1603580400 7200 0 IST} {1616716800 10800 1 IDT} - {1633215600 7200 0 IST} + {1635634800 7200 0 IST} {1648166400 10800 1 IDT} - {1664665200 7200 0 IST} + {1667084400 7200 0 IST} {1679616000 10800 1 IDT} - {1696719600 7200 0 IST} + {1698534000 7200 0 IST} {1711670400 10800 1 IDT} - {1728169200 7200 0 IST} + {1729983600 7200 0 IST} {1743120000 10800 1 IDT} - {1759618800 7200 0 IST} + {1761433200 7200 0 IST} {1774569600 10800 1 IDT} - {1791068400 7200 0 IST} + {1792882800 7200 0 IST} {1806019200 10800 1 IDT} - {1822604400 7200 0 IST} + {1824937200 7200 0 IST} {1837468800 10800 1 IDT} - {1854572400 7200 0 IST} + {1856386800 7200 0 IST} {1868918400 10800 1 IDT} - {1886022000 7200 0 IST} + {1887836400 7200 0 IST} {1900972800 10800 1 IDT} - {1917471600 7200 0 IST} + {1919286000 7200 0 IST} {1932422400 10800 1 IDT} - {1948921200 7200 0 IST} + {1950735600 7200 0 IST} {1963872000 10800 1 IDT} - {1980370800 7200 0 IST} + {1982790000 7200 0 IST} {1995321600 10800 1 IDT} - {2011820400 7200 0 IST} + {2014239600 7200 0 IST} {2026771200 10800 1 IDT} - {2043874800 7200 0 IST} + {2045689200 7200 0 IST} {2058220800 10800 1 IDT} - {2075324400 7200 0 IST} + {2077138800 7200 0 IST} {2090275200 10800 1 IDT} - {2106774000 7200 0 IST} + {2108588400 7200 0 IST} {2121724800 10800 1 IDT} - {2138223600 7200 0 IST} + {2140038000 7200 0 IST} {2153174400 10800 1 IDT} - {2169673200 7200 0 IST} + {2172092400 7200 0 IST} {2184624000 10800 1 IDT} - {2201122800 7200 0 IST} + {2203542000 7200 0 IST} {2216073600 10800 1 IDT} - {2233177200 7200 0 IST} + {2234991600 7200 0 IST} {2248128000 10800 1 IDT} - {2264626800 7200 0 IST} + {2266441200 7200 0 IST} {2279577600 10800 1 IDT} - {2296076400 7200 0 IST} + {2297890800 7200 0 IST} {2311027200 10800 1 IDT} - {2327526000 7200 0 IST} + {2329340400 7200 0 IST} {2342476800 10800 1 IDT} - {2358975600 7200 0 IST} + {2361394800 7200 0 IST} {2373926400 10800 1 IDT} - {2391030000 7200 0 IST} + {2392844400 7200 0 IST} {2405376000 10800 1 IDT} - {2422479600 7200 0 IST} + {2424294000 7200 0 IST} {2437430400 10800 1 IDT} - {2453929200 7200 0 IST} + {2455743600 7200 0 IST} {2468880000 10800 1 IDT} - {2485378800 7200 0 IST} + {2487193200 7200 0 IST} {2500329600 10800 1 IDT} - {2516828400 7200 0 IST} + {2519247600 7200 0 IST} {2531779200 10800 1 IDT} - {2548278000 7200 0 IST} + {2550697200 7200 0 IST} {2563228800 10800 1 IDT} - {2580332400 7200 0 IST} + {2582146800 7200 0 IST} {2595283200 10800 1 IDT} - {2611782000 7200 0 IST} + {2613596400 7200 0 IST} {2626732800 10800 1 IDT} - {2643231600 7200 0 IST} + {2645046000 7200 0 IST} {2658182400 10800 1 IDT} - {2674681200 7200 0 IST} + {2676495600 7200 0 IST} {2689632000 10800 1 IDT} - {2706130800 7200 0 IST} + {2708550000 7200 0 IST} {2721081600 10800 1 IDT} - {2738185200 7200 0 IST} + {2739999600 7200 0 IST} {2752531200 10800 1 IDT} - {2769634800 7200 0 IST} + {2771449200 7200 0 IST} {2784585600 10800 1 IDT} - {2801084400 7200 0 IST} + {2802898800 7200 0 IST} {2816035200 10800 1 IDT} - {2832534000 7200 0 IST} + {2834348400 7200 0 IST} {2847484800 10800 1 IDT} - {2863983600 7200 0 IST} + {2866402800 7200 0 IST} {2878934400 10800 1 IDT} - {2895433200 7200 0 IST} + {2897852400 7200 0 IST} {2910384000 10800 1 IDT} - {2927487600 7200 0 IST} + {2929302000 7200 0 IST} {2941833600 10800 1 IDT} - {2958937200 7200 0 IST} + {2960751600 7200 0 IST} {2973888000 10800 1 IDT} - {2990386800 7200 0 IST} + {2992201200 7200 0 IST} {3005337600 10800 1 IDT} - {3021836400 7200 0 IST} + {3023650800 7200 0 IST} {3036787200 10800 1 IDT} - {3053286000 7200 0 IST} + {3055705200 7200 0 IST} {3068236800 10800 1 IDT} - {3084735600 7200 0 IST} + {3087154800 7200 0 IST} {3099686400 10800 1 IDT} - {3116790000 7200 0 IST} + {3118604400 7200 0 IST} {3131740800 10800 1 IDT} - {3148239600 7200 0 IST} + {3150054000 7200 0 IST} {3163190400 10800 1 IDT} - {3179689200 7200 0 IST} + {3181503600 7200 0 IST} {3194640000 10800 1 IDT} - {3211138800 7200 0 IST} + {3212953200 7200 0 IST} {3226089600 10800 1 IDT} - {3242588400 7200 0 IST} + {3245007600 7200 0 IST} {3257539200 10800 1 IDT} - {3274642800 7200 0 IST} + {3276457200 7200 0 IST} {3288988800 10800 1 IDT} - {3306092400 7200 0 IST} + {3307906800 7200 0 IST} {3321043200 10800 1 IDT} - {3337542000 7200 0 IST} + {3339356400 7200 0 IST} {3352492800 10800 1 IDT} - {3368991600 7200 0 IST} + {3370806000 7200 0 IST} {3383942400 10800 1 IDT} - {3400441200 7200 0 IST} + {3402860400 7200 0 IST} {3415392000 10800 1 IDT} - {3431890800 7200 0 IST} + {3434310000 7200 0 IST} {3446841600 10800 1 IDT} - {3463945200 7200 0 IST} + {3465759600 7200 0 IST} {3478896000 10800 1 IDT} - {3495394800 7200 0 IST} + {3497209200 7200 0 IST} {3510345600 10800 1 IDT} - {3526844400 7200 0 IST} + {3528658800 7200 0 IST} {3541795200 10800 1 IDT} - {3558294000 7200 0 IST} + {3560108400 7200 0 IST} {3573244800 10800 1 IDT} - {3589743600 7200 0 IST} + {3592162800 7200 0 IST} {3604694400 10800 1 IDT} - {3621798000 7200 0 IST} + {3623612400 7200 0 IST} {3636144000 10800 1 IDT} - {3653247600 7200 0 IST} + {3655062000 7200 0 IST} {3668198400 10800 1 IDT} - {3684697200 7200 0 IST} + {3686511600 7200 0 IST} {3699648000 10800 1 IDT} - {3716146800 7200 0 IST} + {3717961200 7200 0 IST} {3731097600 10800 1 IDT} - {3747596400 7200 0 IST} + {3750015600 7200 0 IST} {3762547200 10800 1 IDT} - {3779046000 7200 0 IST} + {3781465200 7200 0 IST} {3793996800 10800 1 IDT} - {3811100400 7200 0 IST} + {3812914800 7200 0 IST} {3825446400 10800 1 IDT} - {3842550000 7200 0 IST} + {3844364400 7200 0 IST} {3857500800 10800 1 IDT} - {3873999600 7200 0 IST} + {3875814000 7200 0 IST} {3888950400 10800 1 IDT} - {3905449200 7200 0 IST} + {3907263600 7200 0 IST} {3920400000 10800 1 IDT} - {3936898800 7200 0 IST} + {3939318000 7200 0 IST} {3951849600 10800 1 IDT} - {3968348400 7200 0 IST} + {3970767600 7200 0 IST} {3983299200 10800 1 IDT} - {4000402800 7200 0 IST} + {4002217200 7200 0 IST} {4015353600 10800 1 IDT} - {4031852400 7200 0 IST} + {4033666800 7200 0 IST} {4046803200 10800 1 IDT} - {4063302000 7200 0 IST} + {4065116400 7200 0 IST} {4078252800 10800 1 IDT} - {4094751600 7200 0 IST} + {4096566000 7200 0 IST} } -- cgit v0.12 From e7f11f7a27708f18bf22dd756d62b5365591b4ce Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 6 Jul 2013 22:24:52 +0000 Subject: http://www.iana.org/time-zones/repository/releases/tzdata2013d.tar.gz --- ChangeLog | 10 ++ library/tzdata/Africa/Casablanca | 4 +- library/tzdata/America/Asuncion | 173 ++++++++++++++++----------------- library/tzdata/Antarctica/Macquarie | 9 +- library/tzdata/Asia/Gaza | 189 ++++++++++++++++++++++++++++++++++-- library/tzdata/Asia/Hebron | 185 +++++++++++++++++++++++++++++++++-- library/tzdata/Asia/Jerusalem | 178 ++++++++++++++++----------------- 7 files changed, 551 insertions(+), 197 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2da02a7..d7ada95 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2013-07-05 Kevin B. Kenny + + * library/tzdata/Africa/Casablanca: + * library/tzdata/America/Asuncion: + * library/tzdata/Antarctica/Macquarie: + * library/tzdata/Asia/Gaza: + * library/tzdata/Asia/Hebron: + * library/tzdata/Asia/Jerusalem: + http://www.iana.org/time-zones/repository/releases/tzdata2013d.tar.gz + 2013-07-03 Jan Nijtmans * unix/tclXtNotify.c: Bug [817249]: bring tclXtNotify.c up to date with diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 74b767a..757007c 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -34,8 +34,8 @@ set TZData(:Africa/Casablanca) { {1345428000 3600 1 WEST} {1348970400 0 0 WET} {1367114400 3600 1 WEST} - {1373335200 0 0 WET} - {1375927200 3600 1 WEST} + {1373162400 0 0 WET} + {1376100000 3600 1 WEST} {1380420000 0 0 WET} {1398564000 3600 1 WEST} {1404007200 0 0 WET} diff --git a/library/tzdata/America/Asuncion b/library/tzdata/America/Asuncion index d530193..9ea30da 100644 --- a/library/tzdata/America/Asuncion +++ b/library/tzdata/America/Asuncion @@ -83,178 +83,177 @@ set TZData(:America/Asuncion) { {1333854000 -14400 0 PYT} {1349582400 -10800 1 PYST} {1364094000 -14400 0 PYT} - {1365912000 -14400 0 PYT} {1381032000 -10800 1 PYST} - {1397358000 -14400 0 PYT} + {1395543600 -14400 0 PYT} {1412481600 -10800 1 PYST} - {1428807600 -14400 0 PYT} + {1426993200 -14400 0 PYT} {1443931200 -10800 1 PYST} - {1460257200 -14400 0 PYT} + {1459047600 -14400 0 PYT} {1475380800 -10800 1 PYST} - {1491706800 -14400 0 PYT} + {1490497200 -14400 0 PYT} {1506830400 -10800 1 PYST} - {1523156400 -14400 0 PYT} + {1521946800 -14400 0 PYT} {1538884800 -10800 1 PYST} - {1555210800 -14400 0 PYT} + {1553396400 -14400 0 PYT} {1570334400 -10800 1 PYST} - {1586660400 -14400 0 PYT} + {1584846000 -14400 0 PYT} {1601784000 -10800 1 PYST} - {1618110000 -14400 0 PYT} + {1616900400 -14400 0 PYT} {1633233600 -10800 1 PYST} - {1649559600 -14400 0 PYT} + {1648350000 -14400 0 PYT} {1664683200 -10800 1 PYST} - {1681009200 -14400 0 PYT} + {1679799600 -14400 0 PYT} {1696132800 -10800 1 PYST} - {1713063600 -14400 0 PYT} + {1711249200 -14400 0 PYT} {1728187200 -10800 1 PYST} - {1744513200 -14400 0 PYT} + {1742698800 -14400 0 PYT} {1759636800 -10800 1 PYST} - {1775962800 -14400 0 PYT} + {1774148400 -14400 0 PYT} {1791086400 -10800 1 PYST} - {1807412400 -14400 0 PYT} + {1806202800 -14400 0 PYT} {1822536000 -10800 1 PYST} - {1838862000 -14400 0 PYT} + {1837652400 -14400 0 PYT} {1853985600 -10800 1 PYST} - {1870311600 -14400 0 PYT} + {1869102000 -14400 0 PYT} {1886040000 -10800 1 PYST} - {1902366000 -14400 0 PYT} + {1900551600 -14400 0 PYT} {1917489600 -10800 1 PYST} - {1933815600 -14400 0 PYT} + {1932001200 -14400 0 PYT} {1948939200 -10800 1 PYST} - {1965265200 -14400 0 PYT} + {1964055600 -14400 0 PYT} {1980388800 -10800 1 PYST} - {1996714800 -14400 0 PYT} + {1995505200 -14400 0 PYT} {2011838400 -10800 1 PYST} - {2028164400 -14400 0 PYT} + {2026954800 -14400 0 PYT} {2043288000 -10800 1 PYST} - {2059614000 -14400 0 PYT} + {2058404400 -14400 0 PYT} {2075342400 -10800 1 PYST} - {2091668400 -14400 0 PYT} + {2089854000 -14400 0 PYT} {2106792000 -10800 1 PYST} - {2123118000 -14400 0 PYT} + {2121303600 -14400 0 PYT} {2138241600 -10800 1 PYST} - {2154567600 -14400 0 PYT} + {2153358000 -14400 0 PYT} {2169691200 -10800 1 PYST} - {2186017200 -14400 0 PYT} + {2184807600 -14400 0 PYT} {2201140800 -10800 1 PYST} - {2217466800 -14400 0 PYT} + {2216257200 -14400 0 PYT} {2233195200 -10800 1 PYST} - {2249521200 -14400 0 PYT} + {2247706800 -14400 0 PYT} {2264644800 -10800 1 PYST} - {2280970800 -14400 0 PYT} + {2279156400 -14400 0 PYT} {2296094400 -10800 1 PYST} - {2312420400 -14400 0 PYT} + {2310606000 -14400 0 PYT} {2327544000 -10800 1 PYST} - {2343870000 -14400 0 PYT} + {2342660400 -14400 0 PYT} {2358993600 -10800 1 PYST} - {2375319600 -14400 0 PYT} + {2374110000 -14400 0 PYT} {2390443200 -10800 1 PYST} - {2406769200 -14400 0 PYT} + {2405559600 -14400 0 PYT} {2422497600 -10800 1 PYST} - {2438823600 -14400 0 PYT} + {2437009200 -14400 0 PYT} {2453947200 -10800 1 PYST} - {2470273200 -14400 0 PYT} + {2468458800 -14400 0 PYT} {2485396800 -10800 1 PYST} - {2501722800 -14400 0 PYT} + {2500513200 -14400 0 PYT} {2516846400 -10800 1 PYST} - {2533172400 -14400 0 PYT} + {2531962800 -14400 0 PYT} {2548296000 -10800 1 PYST} - {2564622000 -14400 0 PYT} + {2563412400 -14400 0 PYT} {2579745600 -10800 1 PYST} - {2596676400 -14400 0 PYT} + {2594862000 -14400 0 PYT} {2611800000 -10800 1 PYST} - {2628126000 -14400 0 PYT} + {2626311600 -14400 0 PYT} {2643249600 -10800 1 PYST} - {2659575600 -14400 0 PYT} + {2657761200 -14400 0 PYT} {2674699200 -10800 1 PYST} - {2691025200 -14400 0 PYT} + {2689815600 -14400 0 PYT} {2706148800 -10800 1 PYST} - {2722474800 -14400 0 PYT} + {2721265200 -14400 0 PYT} {2737598400 -10800 1 PYST} - {2753924400 -14400 0 PYT} + {2752714800 -14400 0 PYT} {2769652800 -10800 1 PYST} - {2785978800 -14400 0 PYT} + {2784164400 -14400 0 PYT} {2801102400 -10800 1 PYST} - {2817428400 -14400 0 PYT} + {2815614000 -14400 0 PYT} {2832552000 -10800 1 PYST} - {2848878000 -14400 0 PYT} + {2847668400 -14400 0 PYT} {2864001600 -10800 1 PYST} - {2880327600 -14400 0 PYT} + {2879118000 -14400 0 PYT} {2895451200 -10800 1 PYST} - {2911777200 -14400 0 PYT} + {2910567600 -14400 0 PYT} {2926900800 -10800 1 PYST} - {2943226800 -14400 0 PYT} + {2942017200 -14400 0 PYT} {2958955200 -10800 1 PYST} - {2975281200 -14400 0 PYT} + {2973466800 -14400 0 PYT} {2990404800 -10800 1 PYST} - {3006730800 -14400 0 PYT} + {3004916400 -14400 0 PYT} {3021854400 -10800 1 PYST} - {3038180400 -14400 0 PYT} + {3036970800 -14400 0 PYT} {3053304000 -10800 1 PYST} - {3069630000 -14400 0 PYT} + {3068420400 -14400 0 PYT} {3084753600 -10800 1 PYST} - {3101079600 -14400 0 PYT} + {3099870000 -14400 0 PYT} {3116808000 -10800 1 PYST} - {3133134000 -14400 0 PYT} + {3131319600 -14400 0 PYT} {3148257600 -10800 1 PYST} - {3164583600 -14400 0 PYT} + {3162769200 -14400 0 PYT} {3179707200 -10800 1 PYST} - {3196033200 -14400 0 PYT} + {3194218800 -14400 0 PYT} {3211156800 -10800 1 PYST} - {3227482800 -14400 0 PYT} + {3226273200 -14400 0 PYT} {3242606400 -10800 1 PYST} - {3258932400 -14400 0 PYT} + {3257722800 -14400 0 PYT} {3274056000 -10800 1 PYST} - {3290382000 -14400 0 PYT} + {3289172400 -14400 0 PYT} {3306110400 -10800 1 PYST} - {3322436400 -14400 0 PYT} + {3320622000 -14400 0 PYT} {3337560000 -10800 1 PYST} - {3353886000 -14400 0 PYT} + {3352071600 -14400 0 PYT} {3369009600 -10800 1 PYST} - {3385335600 -14400 0 PYT} + {3384126000 -14400 0 PYT} {3400459200 -10800 1 PYST} - {3416785200 -14400 0 PYT} + {3415575600 -14400 0 PYT} {3431908800 -10800 1 PYST} - {3448234800 -14400 0 PYT} + {3447025200 -14400 0 PYT} {3463358400 -10800 1 PYST} - {3480289200 -14400 0 PYT} + {3478474800 -14400 0 PYT} {3495412800 -10800 1 PYST} - {3511738800 -14400 0 PYT} + {3509924400 -14400 0 PYT} {3526862400 -10800 1 PYST} - {3543188400 -14400 0 PYT} + {3541374000 -14400 0 PYT} {3558312000 -10800 1 PYST} - {3574638000 -14400 0 PYT} + {3573428400 -14400 0 PYT} {3589761600 -10800 1 PYST} - {3606087600 -14400 0 PYT} + {3604878000 -14400 0 PYT} {3621211200 -10800 1 PYST} - {3637537200 -14400 0 PYT} + {3636327600 -14400 0 PYT} {3653265600 -10800 1 PYST} - {3669591600 -14400 0 PYT} + {3667777200 -14400 0 PYT} {3684715200 -10800 1 PYST} - {3701041200 -14400 0 PYT} + {3699226800 -14400 0 PYT} {3716164800 -10800 1 PYST} - {3732490800 -14400 0 PYT} + {3731281200 -14400 0 PYT} {3747614400 -10800 1 PYST} - {3763940400 -14400 0 PYT} + {3762730800 -14400 0 PYT} {3779064000 -10800 1 PYST} - {3795390000 -14400 0 PYT} + {3794180400 -14400 0 PYT} {3810513600 -10800 1 PYST} - {3826839600 -14400 0 PYT} + {3825630000 -14400 0 PYT} {3842568000 -10800 1 PYST} - {3858894000 -14400 0 PYT} + {3857079600 -14400 0 PYT} {3874017600 -10800 1 PYST} - {3890343600 -14400 0 PYT} + {3888529200 -14400 0 PYT} {3905467200 -10800 1 PYST} - {3921793200 -14400 0 PYT} + {3920583600 -14400 0 PYT} {3936916800 -10800 1 PYST} - {3953242800 -14400 0 PYT} + {3952033200 -14400 0 PYT} {3968366400 -10800 1 PYST} - {3984692400 -14400 0 PYT} + {3983482800 -14400 0 PYT} {4000420800 -10800 1 PYST} - {4016746800 -14400 0 PYT} + {4014932400 -14400 0 PYT} {4031870400 -10800 1 PYST} - {4048196400 -14400 0 PYT} + {4046382000 -14400 0 PYT} {4063320000 -10800 1 PYST} - {4079646000 -14400 0 PYT} + {4077831600 -14400 0 PYT} {4094769600 -10800 1 PYST} } diff --git a/library/tzdata/Antarctica/Macquarie b/library/tzdata/Antarctica/Macquarie index 9877ee8..bd5cf8a 100644 --- a/library/tzdata/Antarctica/Macquarie +++ b/library/tzdata/Antarctica/Macquarie @@ -2,16 +2,11 @@ set TZData(:Antarctica/Macquarie) { {-9223372036854775808 0 0 zzz} - {-1861920000 36000 0 EST} + {-2214259200 36000 0 EST} {-1680508800 39600 1 EST} {-1669892400 39600 0 EST} {-1665392400 36000 0 EST} - {-883641600 39600 1 EST} - {-876128400 36000 0 EST} - {-860400000 39600 1 EST} - {-844678800 36000 0 EST} - {-828345600 39600 1 EST} - {-813229200 36000 0 EST} + {-1601719200 0 0 zzz} {-94730400 36000 0 EST} {-71136000 39600 1 EST} {-55411200 36000 0 EST} diff --git a/library/tzdata/Asia/Gaza b/library/tzdata/Asia/Gaza index 43e1847..a0636e2 100644 --- a/library/tzdata/Asia/Gaza +++ b/library/tzdata/Asia/Gaza @@ -88,14 +88,191 @@ set TZData(:Asia/Gaza) { {1158872400 7200 0 EET} {1175378400 10800 1 EEST} {1189638000 7200 0 EET} - {1207000800 10800 1 EEST} - {1219957200 7200 0 EET} + {1206655200 10800 1 EEST} + {1219960800 7200 0 EET} + {1220220000 7200 0 EET} {1238104800 10800 1 EEST} - {1252018800 7200 0 EET} - {1269640860 10800 1 EEST} + {1252015200 7200 0 EET} + {1262296800 7200 0 EET} + {1269640860 10800 0 EEST} {1281474000 7200 0 EET} - {1301738460 10800 1 EEST} - {1312146000 7200 0 EET} + {1301608860 10800 1 EEST} + {1312149600 7200 0 EET} + {1325368800 7200 0 EET} {1333058400 10800 1 EEST} {1348178400 7200 0 EET} + {1364508000 10800 1 EEST} + {1380232800 7200 0 EET} + {1395957600 10800 1 EEST} + {1411682400 7200 0 EET} + {1427407200 10800 1 EEST} + {1443132000 7200 0 EET} + {1459461600 10800 1 EEST} + {1474581600 7200 0 EET} + {1490911200 10800 1 EEST} + {1506031200 7200 0 EET} + {1522360800 10800 1 EEST} + {1537480800 7200 0 EET} + {1553810400 10800 1 EEST} + {1569535200 7200 0 EET} + {1585260000 10800 1 EEST} + {1600984800 7200 0 EET} + {1616709600 10800 1 EEST} + {1632434400 7200 0 EET} + {1648764000 10800 1 EEST} + {1663884000 7200 0 EET} + {1680213600 10800 1 EEST} + {1695333600 7200 0 EET} + {1711663200 10800 1 EEST} + {1727388000 7200 0 EET} + {1743112800 10800 1 EEST} + {1758837600 7200 0 EET} + {1774562400 10800 1 EEST} + {1790287200 7200 0 EET} + {1806012000 10800 1 EEST} + {1821736800 7200 0 EET} + {1838066400 10800 1 EEST} + {1853186400 7200 0 EET} + {1869516000 10800 1 EEST} + {1884636000 7200 0 EET} + {1900965600 10800 1 EEST} + {1916690400 7200 0 EET} + {1932415200 10800 1 EEST} + {1948140000 7200 0 EET} + {1963864800 10800 1 EEST} + {1979589600 7200 0 EET} + {1995919200 10800 1 EEST} + {2011039200 7200 0 EET} + {2027368800 10800 1 EEST} + {2042488800 7200 0 EET} + {2058818400 10800 1 EEST} + {2073938400 7200 0 EET} + {2090268000 10800 1 EEST} + {2105992800 7200 0 EET} + {2121717600 10800 1 EEST} + {2137442400 7200 0 EET} + {2153167200 10800 1 EEST} + {2168892000 7200 0 EET} + {2185221600 10800 1 EEST} + {2200341600 7200 0 EET} + {2216671200 10800 1 EEST} + {2231791200 7200 0 EET} + {2248120800 10800 1 EEST} + {2263845600 7200 0 EET} + {2279570400 10800 1 EEST} + {2295295200 7200 0 EET} + {2311020000 10800 1 EEST} + {2326744800 7200 0 EET} + {2343074400 10800 1 EEST} + {2358194400 7200 0 EET} + {2374524000 10800 1 EEST} + {2389644000 7200 0 EET} + {2405973600 10800 1 EEST} + {2421093600 7200 0 EET} + {2437423200 10800 1 EEST} + {2453148000 7200 0 EET} + {2468872800 10800 1 EEST} + {2484597600 7200 0 EET} + {2500322400 10800 1 EEST} + {2516047200 7200 0 EET} + {2532376800 10800 1 EEST} + {2547496800 7200 0 EET} + {2563826400 10800 1 EEST} + {2578946400 7200 0 EET} + {2595276000 10800 1 EEST} + {2611000800 7200 0 EET} + {2626725600 10800 1 EEST} + {2642450400 7200 0 EET} + {2658175200 10800 1 EEST} + {2673900000 7200 0 EET} + {2689624800 10800 1 EEST} + {2705349600 7200 0 EET} + {2721679200 10800 1 EEST} + {2736799200 7200 0 EET} + {2753128800 10800 1 EEST} + {2768248800 7200 0 EET} + {2784578400 10800 1 EEST} + {2800303200 7200 0 EET} + {2816028000 10800 1 EEST} + {2831752800 7200 0 EET} + {2847477600 10800 1 EEST} + {2863202400 7200 0 EET} + {2879532000 10800 1 EEST} + {2894652000 7200 0 EET} + {2910981600 10800 1 EEST} + {2926101600 7200 0 EET} + {2942431200 10800 1 EEST} + {2957551200 7200 0 EET} + {2973880800 10800 1 EEST} + {2989605600 7200 0 EET} + {3005330400 10800 1 EEST} + {3021055200 7200 0 EET} + {3036780000 10800 1 EEST} + {3052504800 7200 0 EET} + {3068834400 10800 1 EEST} + {3083954400 7200 0 EET} + {3100284000 10800 1 EEST} + {3115404000 7200 0 EET} + {3131733600 10800 1 EEST} + {3147458400 7200 0 EET} + {3163183200 10800 1 EEST} + {3178908000 7200 0 EET} + {3194632800 10800 1 EEST} + {3210357600 7200 0 EET} + {3226687200 10800 1 EEST} + {3241807200 7200 0 EET} + {3258136800 10800 1 EEST} + {3273256800 7200 0 EET} + {3289586400 10800 1 EEST} + {3304706400 7200 0 EET} + {3321036000 10800 1 EEST} + {3336760800 7200 0 EET} + {3352485600 10800 1 EEST} + {3368210400 7200 0 EET} + {3383935200 10800 1 EEST} + {3399660000 7200 0 EET} + {3415989600 10800 1 EEST} + {3431109600 7200 0 EET} + {3447439200 10800 1 EEST} + {3462559200 7200 0 EET} + {3478888800 10800 1 EEST} + {3494613600 7200 0 EET} + {3510338400 10800 1 EEST} + {3526063200 7200 0 EET} + {3541788000 10800 1 EEST} + {3557512800 7200 0 EET} + {3573237600 10800 1 EEST} + {3588962400 7200 0 EET} + {3605292000 10800 1 EEST} + {3620412000 7200 0 EET} + {3636741600 10800 1 EEST} + {3651861600 7200 0 EET} + {3668191200 10800 1 EEST} + {3683916000 7200 0 EET} + {3699640800 10800 1 EEST} + {3715365600 7200 0 EET} + {3731090400 10800 1 EEST} + {3746815200 7200 0 EET} + {3763144800 10800 1 EEST} + {3778264800 7200 0 EET} + {3794594400 10800 1 EEST} + {3809714400 7200 0 EET} + {3826044000 10800 1 EEST} + {3841164000 7200 0 EET} + {3857493600 10800 1 EEST} + {3873218400 7200 0 EET} + {3888943200 10800 1 EEST} + {3904668000 7200 0 EET} + {3920392800 10800 1 EEST} + {3936117600 7200 0 EET} + {3952447200 10800 1 EEST} + {3967567200 7200 0 EET} + {3983896800 10800 1 EEST} + {3999016800 7200 0 EET} + {4015346400 10800 1 EEST} + {4031071200 7200 0 EET} + {4046796000 10800 1 EEST} + {4062520800 7200 0 EET} + {4078245600 10800 1 EEST} + {4093970400 7200 0 EET} } diff --git a/library/tzdata/Asia/Hebron b/library/tzdata/Asia/Hebron index 98bb353..a8a9019 100644 --- a/library/tzdata/Asia/Hebron +++ b/library/tzdata/Asia/Hebron @@ -88,17 +88,190 @@ set TZData(:Asia/Hebron) { {1158872400 7200 0 EET} {1175378400 10800 1 EEST} {1189638000 7200 0 EET} - {1207000800 10800 1 EEST} - {1217541600 10800 1 EEST} + {1206655200 10800 1 EEST} {1220216400 7200 0 EET} {1238104800 10800 1 EEST} - {1252018800 7200 0 EET} - {1269640860 10800 1 EEST} + {1252015200 7200 0 EET} + {1269554400 10800 1 EEST} {1281474000 7200 0 EET} - {1301652060 10800 1 EEST} + {1301608860 10800 1 EEST} {1312146000 7200 0 EET} {1314655200 10800 1 EEST} - {1317340800 7200 0 EET} + {1317330000 7200 0 EET} {1333058400 10800 1 EEST} {1348178400 7200 0 EET} + {1364508000 10800 1 EEST} + {1380232800 7200 0 EET} + {1395957600 10800 1 EEST} + {1411682400 7200 0 EET} + {1427407200 10800 1 EEST} + {1443132000 7200 0 EET} + {1459461600 10800 1 EEST} + {1474581600 7200 0 EET} + {1490911200 10800 1 EEST} + {1506031200 7200 0 EET} + {1522360800 10800 1 EEST} + {1537480800 7200 0 EET} + {1553810400 10800 1 EEST} + {1569535200 7200 0 EET} + {1585260000 10800 1 EEST} + {1600984800 7200 0 EET} + {1616709600 10800 1 EEST} + {1632434400 7200 0 EET} + {1648764000 10800 1 EEST} + {1663884000 7200 0 EET} + {1680213600 10800 1 EEST} + {1695333600 7200 0 EET} + {1711663200 10800 1 EEST} + {1727388000 7200 0 EET} + {1743112800 10800 1 EEST} + {1758837600 7200 0 EET} + {1774562400 10800 1 EEST} + {1790287200 7200 0 EET} + {1806012000 10800 1 EEST} + {1821736800 7200 0 EET} + {1838066400 10800 1 EEST} + {1853186400 7200 0 EET} + {1869516000 10800 1 EEST} + {1884636000 7200 0 EET} + {1900965600 10800 1 EEST} + {1916690400 7200 0 EET} + {1932415200 10800 1 EEST} + {1948140000 7200 0 EET} + {1963864800 10800 1 EEST} + {1979589600 7200 0 EET} + {1995919200 10800 1 EEST} + {2011039200 7200 0 EET} + {2027368800 10800 1 EEST} + {2042488800 7200 0 EET} + {2058818400 10800 1 EEST} + {2073938400 7200 0 EET} + {2090268000 10800 1 EEST} + {2105992800 7200 0 EET} + {2121717600 10800 1 EEST} + {2137442400 7200 0 EET} + {2153167200 10800 1 EEST} + {2168892000 7200 0 EET} + {2185221600 10800 1 EEST} + {2200341600 7200 0 EET} + {2216671200 10800 1 EEST} + {2231791200 7200 0 EET} + {2248120800 10800 1 EEST} + {2263845600 7200 0 EET} + {2279570400 10800 1 EEST} + {2295295200 7200 0 EET} + {2311020000 10800 1 EEST} + {2326744800 7200 0 EET} + {2343074400 10800 1 EEST} + {2358194400 7200 0 EET} + {2374524000 10800 1 EEST} + {2389644000 7200 0 EET} + {2405973600 10800 1 EEST} + {2421093600 7200 0 EET} + {2437423200 10800 1 EEST} + {2453148000 7200 0 EET} + {2468872800 10800 1 EEST} + {2484597600 7200 0 EET} + {2500322400 10800 1 EEST} + {2516047200 7200 0 EET} + {2532376800 10800 1 EEST} + {2547496800 7200 0 EET} + {2563826400 10800 1 EEST} + {2578946400 7200 0 EET} + {2595276000 10800 1 EEST} + {2611000800 7200 0 EET} + {2626725600 10800 1 EEST} + {2642450400 7200 0 EET} + {2658175200 10800 1 EEST} + {2673900000 7200 0 EET} + {2689624800 10800 1 EEST} + {2705349600 7200 0 EET} + {2721679200 10800 1 EEST} + {2736799200 7200 0 EET} + {2753128800 10800 1 EEST} + {2768248800 7200 0 EET} + {2784578400 10800 1 EEST} + {2800303200 7200 0 EET} + {2816028000 10800 1 EEST} + {2831752800 7200 0 EET} + {2847477600 10800 1 EEST} + {2863202400 7200 0 EET} + {2879532000 10800 1 EEST} + {2894652000 7200 0 EET} + {2910981600 10800 1 EEST} + {2926101600 7200 0 EET} + {2942431200 10800 1 EEST} + {2957551200 7200 0 EET} + {2973880800 10800 1 EEST} + {2989605600 7200 0 EET} + {3005330400 10800 1 EEST} + {3021055200 7200 0 EET} + {3036780000 10800 1 EEST} + {3052504800 7200 0 EET} + {3068834400 10800 1 EEST} + {3083954400 7200 0 EET} + {3100284000 10800 1 EEST} + {3115404000 7200 0 EET} + {3131733600 10800 1 EEST} + {3147458400 7200 0 EET} + {3163183200 10800 1 EEST} + {3178908000 7200 0 EET} + {3194632800 10800 1 EEST} + {3210357600 7200 0 EET} + {3226687200 10800 1 EEST} + {3241807200 7200 0 EET} + {3258136800 10800 1 EEST} + {3273256800 7200 0 EET} + {3289586400 10800 1 EEST} + {3304706400 7200 0 EET} + {3321036000 10800 1 EEST} + {3336760800 7200 0 EET} + {3352485600 10800 1 EEST} + {3368210400 7200 0 EET} + {3383935200 10800 1 EEST} + {3399660000 7200 0 EET} + {3415989600 10800 1 EEST} + {3431109600 7200 0 EET} + {3447439200 10800 1 EEST} + {3462559200 7200 0 EET} + {3478888800 10800 1 EEST} + {3494613600 7200 0 EET} + {3510338400 10800 1 EEST} + {3526063200 7200 0 EET} + {3541788000 10800 1 EEST} + {3557512800 7200 0 EET} + {3573237600 10800 1 EEST} + {3588962400 7200 0 EET} + {3605292000 10800 1 EEST} + {3620412000 7200 0 EET} + {3636741600 10800 1 EEST} + {3651861600 7200 0 EET} + {3668191200 10800 1 EEST} + {3683916000 7200 0 EET} + {3699640800 10800 1 EEST} + {3715365600 7200 0 EET} + {3731090400 10800 1 EEST} + {3746815200 7200 0 EET} + {3763144800 10800 1 EEST} + {3778264800 7200 0 EET} + {3794594400 10800 1 EEST} + {3809714400 7200 0 EET} + {3826044000 10800 1 EEST} + {3841164000 7200 0 EET} + {3857493600 10800 1 EEST} + {3873218400 7200 0 EET} + {3888943200 10800 1 EEST} + {3904668000 7200 0 EET} + {3920392800 10800 1 EEST} + {3936117600 7200 0 EET} + {3952447200 10800 1 EEST} + {3967567200 7200 0 EET} + {3983896800 10800 1 EEST} + {3999016800 7200 0 EET} + {4015346400 10800 1 EEST} + {4031071200 7200 0 EET} + {4046796000 10800 1 EEST} + {4062520800 7200 0 EET} + {4078245600 10800 1 EEST} + {4093970400 7200 0 EET} } diff --git a/library/tzdata/Asia/Jerusalem b/library/tzdata/Asia/Jerusalem index 613eadd..7662680 100644 --- a/library/tzdata/Asia/Jerusalem +++ b/library/tzdata/Asia/Jerusalem @@ -1,8 +1,8 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Asia/Jerusalem) { - {-9223372036854775808 8456 0 LMT} - {-2840149256 8440 0 JMT} + {-9223372036854775808 8454 0 LMT} + {-2840149254 8440 0 JMT} {-1641003640 7200 0 IST} {-933645600 10800 1 IDT} {-857358000 7200 0 IST} @@ -96,177 +96,177 @@ set TZData(:Asia/Jerusalem) { {1333065600 10800 1 IDT} {1348354800 7200 0 IST} {1364515200 10800 1 IDT} - {1381014000 7200 0 IST} + {1382828400 7200 0 IST} {1395964800 10800 1 IDT} - {1412463600 7200 0 IST} + {1414278000 7200 0 IST} {1427414400 10800 1 IDT} - {1443913200 7200 0 IST} + {1445727600 7200 0 IST} {1458864000 10800 1 IDT} - {1475362800 7200 0 IST} + {1477782000 7200 0 IST} {1490313600 10800 1 IDT} - {1507417200 7200 0 IST} + {1509231600 7200 0 IST} {1521763200 10800 1 IDT} - {1538866800 7200 0 IST} + {1540681200 7200 0 IST} {1553817600 10800 1 IDT} - {1570316400 7200 0 IST} + {1572130800 7200 0 IST} {1585267200 10800 1 IDT} - {1601766000 7200 0 IST} + {1603580400 7200 0 IST} {1616716800 10800 1 IDT} - {1633215600 7200 0 IST} + {1635634800 7200 0 IST} {1648166400 10800 1 IDT} - {1664665200 7200 0 IST} + {1667084400 7200 0 IST} {1679616000 10800 1 IDT} - {1696719600 7200 0 IST} + {1698534000 7200 0 IST} {1711670400 10800 1 IDT} - {1728169200 7200 0 IST} + {1729983600 7200 0 IST} {1743120000 10800 1 IDT} - {1759618800 7200 0 IST} + {1761433200 7200 0 IST} {1774569600 10800 1 IDT} - {1791068400 7200 0 IST} + {1792882800 7200 0 IST} {1806019200 10800 1 IDT} - {1822604400 7200 0 IST} + {1824937200 7200 0 IST} {1837468800 10800 1 IDT} - {1854572400 7200 0 IST} + {1856386800 7200 0 IST} {1868918400 10800 1 IDT} - {1886022000 7200 0 IST} + {1887836400 7200 0 IST} {1900972800 10800 1 IDT} - {1917471600 7200 0 IST} + {1919286000 7200 0 IST} {1932422400 10800 1 IDT} - {1948921200 7200 0 IST} + {1950735600 7200 0 IST} {1963872000 10800 1 IDT} - {1980370800 7200 0 IST} + {1982790000 7200 0 IST} {1995321600 10800 1 IDT} - {2011820400 7200 0 IST} + {2014239600 7200 0 IST} {2026771200 10800 1 IDT} - {2043874800 7200 0 IST} + {2045689200 7200 0 IST} {2058220800 10800 1 IDT} - {2075324400 7200 0 IST} + {2077138800 7200 0 IST} {2090275200 10800 1 IDT} - {2106774000 7200 0 IST} + {2108588400 7200 0 IST} {2121724800 10800 1 IDT} - {2138223600 7200 0 IST} + {2140038000 7200 0 IST} {2153174400 10800 1 IDT} - {2169673200 7200 0 IST} + {2172092400 7200 0 IST} {2184624000 10800 1 IDT} - {2201122800 7200 0 IST} + {2203542000 7200 0 IST} {2216073600 10800 1 IDT} - {2233177200 7200 0 IST} + {2234991600 7200 0 IST} {2248128000 10800 1 IDT} - {2264626800 7200 0 IST} + {2266441200 7200 0 IST} {2279577600 10800 1 IDT} - {2296076400 7200 0 IST} + {2297890800 7200 0 IST} {2311027200 10800 1 IDT} - {2327526000 7200 0 IST} + {2329340400 7200 0 IST} {2342476800 10800 1 IDT} - {2358975600 7200 0 IST} + {2361394800 7200 0 IST} {2373926400 10800 1 IDT} - {2391030000 7200 0 IST} + {2392844400 7200 0 IST} {2405376000 10800 1 IDT} - {2422479600 7200 0 IST} + {2424294000 7200 0 IST} {2437430400 10800 1 IDT} - {2453929200 7200 0 IST} + {2455743600 7200 0 IST} {2468880000 10800 1 IDT} - {2485378800 7200 0 IST} + {2487193200 7200 0 IST} {2500329600 10800 1 IDT} - {2516828400 7200 0 IST} + {2519247600 7200 0 IST} {2531779200 10800 1 IDT} - {2548278000 7200 0 IST} + {2550697200 7200 0 IST} {2563228800 10800 1 IDT} - {2580332400 7200 0 IST} + {2582146800 7200 0 IST} {2595283200 10800 1 IDT} - {2611782000 7200 0 IST} + {2613596400 7200 0 IST} {2626732800 10800 1 IDT} - {2643231600 7200 0 IST} + {2645046000 7200 0 IST} {2658182400 10800 1 IDT} - {2674681200 7200 0 IST} + {2676495600 7200 0 IST} {2689632000 10800 1 IDT} - {2706130800 7200 0 IST} + {2708550000 7200 0 IST} {2721081600 10800 1 IDT} - {2738185200 7200 0 IST} + {2739999600 7200 0 IST} {2752531200 10800 1 IDT} - {2769634800 7200 0 IST} + {2771449200 7200 0 IST} {2784585600 10800 1 IDT} - {2801084400 7200 0 IST} + {2802898800 7200 0 IST} {2816035200 10800 1 IDT} - {2832534000 7200 0 IST} + {2834348400 7200 0 IST} {2847484800 10800 1 IDT} - {2863983600 7200 0 IST} + {2866402800 7200 0 IST} {2878934400 10800 1 IDT} - {2895433200 7200 0 IST} + {2897852400 7200 0 IST} {2910384000 10800 1 IDT} - {2927487600 7200 0 IST} + {2929302000 7200 0 IST} {2941833600 10800 1 IDT} - {2958937200 7200 0 IST} + {2960751600 7200 0 IST} {2973888000 10800 1 IDT} - {2990386800 7200 0 IST} + {2992201200 7200 0 IST} {3005337600 10800 1 IDT} - {3021836400 7200 0 IST} + {3023650800 7200 0 IST} {3036787200 10800 1 IDT} - {3053286000 7200 0 IST} + {3055705200 7200 0 IST} {3068236800 10800 1 IDT} - {3084735600 7200 0 IST} + {3087154800 7200 0 IST} {3099686400 10800 1 IDT} - {3116790000 7200 0 IST} + {3118604400 7200 0 IST} {3131740800 10800 1 IDT} - {3148239600 7200 0 IST} + {3150054000 7200 0 IST} {3163190400 10800 1 IDT} - {3179689200 7200 0 IST} + {3181503600 7200 0 IST} {3194640000 10800 1 IDT} - {3211138800 7200 0 IST} + {3212953200 7200 0 IST} {3226089600 10800 1 IDT} - {3242588400 7200 0 IST} + {3245007600 7200 0 IST} {3257539200 10800 1 IDT} - {3274642800 7200 0 IST} + {3276457200 7200 0 IST} {3288988800 10800 1 IDT} - {3306092400 7200 0 IST} + {3307906800 7200 0 IST} {3321043200 10800 1 IDT} - {3337542000 7200 0 IST} + {3339356400 7200 0 IST} {3352492800 10800 1 IDT} - {3368991600 7200 0 IST} + {3370806000 7200 0 IST} {3383942400 10800 1 IDT} - {3400441200 7200 0 IST} + {3402860400 7200 0 IST} {3415392000 10800 1 IDT} - {3431890800 7200 0 IST} + {3434310000 7200 0 IST} {3446841600 10800 1 IDT} - {3463945200 7200 0 IST} + {3465759600 7200 0 IST} {3478896000 10800 1 IDT} - {3495394800 7200 0 IST} + {3497209200 7200 0 IST} {3510345600 10800 1 IDT} - {3526844400 7200 0 IST} + {3528658800 7200 0 IST} {3541795200 10800 1 IDT} - {3558294000 7200 0 IST} + {3560108400 7200 0 IST} {3573244800 10800 1 IDT} - {3589743600 7200 0 IST} + {3592162800 7200 0 IST} {3604694400 10800 1 IDT} - {3621798000 7200 0 IST} + {3623612400 7200 0 IST} {3636144000 10800 1 IDT} - {3653247600 7200 0 IST} + {3655062000 7200 0 IST} {3668198400 10800 1 IDT} - {3684697200 7200 0 IST} + {3686511600 7200 0 IST} {3699648000 10800 1 IDT} - {3716146800 7200 0 IST} + {3717961200 7200 0 IST} {3731097600 10800 1 IDT} - {3747596400 7200 0 IST} + {3750015600 7200 0 IST} {3762547200 10800 1 IDT} - {3779046000 7200 0 IST} + {3781465200 7200 0 IST} {3793996800 10800 1 IDT} - {3811100400 7200 0 IST} + {3812914800 7200 0 IST} {3825446400 10800 1 IDT} - {3842550000 7200 0 IST} + {3844364400 7200 0 IST} {3857500800 10800 1 IDT} - {3873999600 7200 0 IST} + {3875814000 7200 0 IST} {3888950400 10800 1 IDT} - {3905449200 7200 0 IST} + {3907263600 7200 0 IST} {3920400000 10800 1 IDT} - {3936898800 7200 0 IST} + {3939318000 7200 0 IST} {3951849600 10800 1 IDT} - {3968348400 7200 0 IST} + {3970767600 7200 0 IST} {3983299200 10800 1 IDT} - {4000402800 7200 0 IST} + {4002217200 7200 0 IST} {4015353600 10800 1 IDT} - {4031852400 7200 0 IST} + {4033666800 7200 0 IST} {4046803200 10800 1 IDT} - {4063302000 7200 0 IST} + {4065116400 7200 0 IST} {4078252800 10800 1 IDT} - {4094751600 7200 0 IST} + {4096566000 7200 0 IST} } -- cgit v0.12 From ad165aa47207de1b44bf47bbaca5673d1ab25f9d Mon Sep 17 00:00:00 2001 From: stwo Date: Sun, 7 Jul 2013 01:09:10 +0000 Subject: OpenBSD/m88k is now elf. Remove unneeded elf check. --- unix/configure | 43 ++++--------------------------------------- unix/tcl.m4 | 15 ++++----------- 2 files changed, 8 insertions(+), 50 deletions(-) diff --git a/unix/configure b/unix/configure index e440baa..ba874fa 100755 --- a/unix/configure +++ b/unix/configure @@ -7794,11 +7794,12 @@ fi OpenBSD-*) arch=`arch -s` case "$arch" in - m88k|vax) + vax) # Equivalent using configure option --disable-load # Step 4 will set the necessary variables DL_OBJS="" SHLIB_LD_LIBS="" + LDFLAGS="" ;; *) SHLIB_CFLAGS="-fPIC" @@ -7813,10 +7814,11 @@ fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' + LDFLAGS="-Wl,-export-dynamic" ;; esac case "$arch" in - m88k|vax) + vax) CFLAGS_OPTIMIZE="-O1" ;; sh) @@ -7826,43 +7828,6 @@ fi CFLAGS_OPTIMIZE="-O2" ;; esac - echo "$as_me:$LINENO: checking for ELF" >&5 -echo $ECHO_N "checking for ELF... $ECHO_C" >&6 -if test "${tcl_cv_ld_elf+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -#ifdef __ELF__ - yes -#endif - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "yes" >/dev/null 2>&1; then - tcl_cv_ld_elf=yes -else - tcl_cv_ld_elf=no -fi -rm -f conftest* - -fi -echo "$as_me:$LINENO: result: $tcl_cv_ld_elf" >&5 -echo "${ECHO_T}$tcl_cv_ld_elf" >&6 - if test $tcl_cv_ld_elf = yes; then - - LDFLAGS=-Wl,-export-dynamic - -else - LDFLAGS="" -fi - if test "${TCL_THREADS}" = "1"; then # On OpenBSD: Compile with -pthread diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 0ac4fb1..1ded260 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1510,11 +1510,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ OpenBSD-*) arch=`arch -s` case "$arch" in - m88k|vax) + vax) # Equivalent using configure option --disable-load # Step 4 will set the necessary variables DL_OBJS="" SHLIB_LD_LIBS="" + LDFLAGS="" ;; *) SHLIB_CFLAGS="-fPIC" @@ -1526,10 +1527,11 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' + LDFLAGS="-Wl,-export-dynamic" ;; esac case "$arch" in - m88k|vax) + vax) CFLAGS_OPTIMIZE="-O1" ;; sh) @@ -1539,15 +1541,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_OPTIMIZE="-O2" ;; esac - AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [ - AC_EGREP_CPP(yes, [ -#ifdef __ELF__ - yes -#endif - ], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)]) - AS_IF([test $tcl_cv_ld_elf = yes], [ - LDFLAGS=-Wl,-export-dynamic - ], [LDFLAGS=""]) AS_IF([test "${TCL_THREADS}" = "1"], [ # On OpenBSD: Compile with -pthread # Don't link with -lpthread -- cgit v0.12 From 8f192fb2d5bb99a3eba996b1dae5fb1b52e13496 Mon Sep 17 00:00:00 2001 From: stwo Date: Sun, 7 Jul 2013 02:11:57 +0000 Subject: OpenBSD/m88k is now elf. Remove unneeded elf check. --- unix/configure | 43 ++++--------------------------------------- unix/tcl.m4 | 15 ++++----------- 2 files changed, 8 insertions(+), 50 deletions(-) diff --git a/unix/configure b/unix/configure index d37aa4f..f219255 100755 --- a/unix/configure +++ b/unix/configure @@ -7727,11 +7727,12 @@ fi OpenBSD-*) arch=`arch -s` case "$arch" in - m88k|vax) + vax) # Equivalent using configure option --disable-load # Step 4 will set the necessary variables DL_OBJS="" SHLIB_LD_LIBS="" + LDFLAGS="" ;; *) SHLIB_CFLAGS="-fPIC" @@ -7746,10 +7747,11 @@ fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' + LDFLAGS="-Wl,-export-dynamic" ;; esac case "$arch" in - m88k|vax) + vax) CFLAGS_OPTIMIZE="-O1" ;; sh) @@ -7759,43 +7761,6 @@ fi CFLAGS_OPTIMIZE="-O2" ;; esac - echo "$as_me:$LINENO: checking for ELF" >&5 -echo $ECHO_N "checking for ELF... $ECHO_C" >&6 -if test "${tcl_cv_ld_elf+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -#ifdef __ELF__ - yes -#endif - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "yes" >/dev/null 2>&1; then - tcl_cv_ld_elf=yes -else - tcl_cv_ld_elf=no -fi -rm -f conftest* - -fi -echo "$as_me:$LINENO: result: $tcl_cv_ld_elf" >&5 -echo "${ECHO_T}$tcl_cv_ld_elf" >&6 - if test $tcl_cv_ld_elf = yes; then - - LDFLAGS=-Wl,-export-dynamic - -else - LDFLAGS="" -fi - if test "${TCL_THREADS}" = "1"; then # On OpenBSD: Compile with -pthread diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 4656e61..b9b6532 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1473,11 +1473,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ OpenBSD-*) arch=`arch -s` case "$arch" in - m88k|vax) + vax) # Equivalent using configure option --disable-load # Step 4 will set the necessary variables DL_OBJS="" SHLIB_LD_LIBS="" + LDFLAGS="" ;; *) SHLIB_CFLAGS="-fPIC" @@ -1489,10 +1490,11 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' + LDFLAGS="-Wl,-export-dynamic" ;; esac case "$arch" in - m88k|vax) + vax) CFLAGS_OPTIMIZE="-O1" ;; sh) @@ -1502,15 +1504,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_OPTIMIZE="-O2" ;; esac - AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [ - AC_EGREP_CPP(yes, [ -#ifdef __ELF__ - yes -#endif - ], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)]) - AS_IF([test $tcl_cv_ld_elf = yes], [ - LDFLAGS=-Wl,-export-dynamic - ], [LDFLAGS=""]) AS_IF([test "${TCL_THREADS}" = "1"], [ # On OpenBSD: Compile with -pthread # Don't link with -lpthread -- cgit v0.12 From 29bb4e46858b3dc971489d3c6c633ae3028304fc Mon Sep 17 00:00:00 2001 From: stwo Date: Sun, 7 Jul 2013 02:19:20 +0000 Subject: OpenBSD/m88k is now elf. Remove unneeded elf check. --- unix/configure | 43 ++++--------------------------------------- unix/tcl.m4 | 15 ++++----------- 2 files changed, 8 insertions(+), 50 deletions(-) diff --git a/unix/configure b/unix/configure index 3e04284..6faa7d8 100755 --- a/unix/configure +++ b/unix/configure @@ -7562,11 +7562,12 @@ fi OpenBSD-*) arch=`arch -s` case "$arch" in - m88k|vax) + vax) # Equivalent using configure option --disable-load # Step 4 will set the necessary variables DL_OBJS="" SHLIB_LD_LIBS="" + LDFLAGS="" ;; *) SHLIB_CFLAGS="-fPIC" @@ -7581,10 +7582,11 @@ fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' + LDFLAGS="-Wl,-export-dynamic" ;; esac case "$arch" in - m88k|vax) + vax) CFLAGS_OPTIMIZE="-O1" ;; sh) @@ -7594,43 +7596,6 @@ fi CFLAGS_OPTIMIZE="-O2" ;; esac - echo "$as_me:$LINENO: checking for ELF" >&5 -echo $ECHO_N "checking for ELF... $ECHO_C" >&6 -if test "${tcl_cv_ld_elf+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -#ifdef __ELF__ - yes -#endif - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "yes" >/dev/null 2>&1; then - tcl_cv_ld_elf=yes -else - tcl_cv_ld_elf=no -fi -rm -f conftest* - -fi -echo "$as_me:$LINENO: result: $tcl_cv_ld_elf" >&5 -echo "${ECHO_T}$tcl_cv_ld_elf" >&6 - if test $tcl_cv_ld_elf = yes; then - - LDFLAGS=-Wl,-export-dynamic - -else - LDFLAGS="" -fi - if test "${TCL_THREADS}" = "1"; then # On OpenBSD: Compile with -pthread diff --git a/unix/tcl.m4 b/unix/tcl.m4 index cdc5f99..879d810 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1484,11 +1484,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ OpenBSD-*) arch=`arch -s` case "$arch" in - m88k|vax) + vax) # Equivalent using configure option --disable-load # Step 4 will set the necessary variables DL_OBJS="" SHLIB_LD_LIBS="" + LDFLAGS="" ;; *) SHLIB_CFLAGS="-fPIC" @@ -1500,10 +1501,11 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' + LDFLAGS="-Wl,-export-dynamic" ;; esac case "$arch" in - m88k|vax) + vax) CFLAGS_OPTIMIZE="-O1" ;; sh) @@ -1513,15 +1515,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_OPTIMIZE="-O2" ;; esac - AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [ - AC_EGREP_CPP(yes, [ -#ifdef __ELF__ - yes -#endif - ], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)]) - AS_IF([test $tcl_cv_ld_elf = yes], [ - LDFLAGS=-Wl,-export-dynamic - ], [LDFLAGS=""]) AS_IF([test "${TCL_THREADS}" = "1"], [ # On OpenBSD: Compile with -pthread # Don't link with -lpthread -- cgit v0.12 From 2a8fc2f6742ccb70838789cfb3c3713cc6fe681d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Jul 2013 06:49:44 +0000 Subject: Build stub objects with -DSTATIC_BUILD on all platforms. Only important on win32 (already done) and cygwin, on other platforms it should not have any effect. --- unix/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 34c7165..f6c4424 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1529,7 +1529,7 @@ waitpid.o: $(COMPAT_DIR)/waitpid.c # even though they will be placed in a static archive tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c - $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c + $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLib.c .c.o: $(CC) -c $(CC_SWITCHES) $< -- cgit v0.12 From 4e5f3c749a2ed1b7c44cb7d1040ed19b03898b18 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 14:31:14 +0000 Subject: The routines StartExpanding() and EnterCmdWordData() are orthogonal, so it's ok to reverse the order in which they are called. --- generic/tclCompile.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5aab69c..0dc30e2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1802,10 +1802,6 @@ CompileCommandTokens( EnterCmdStartData(envPtr, cmdIdx, parsePtr->commandStart - envPtr->source, startCodeOffset); - if (expand && !cmdPtr) { - StartExpanding(envPtr); - } - /* * TIP #280. Scan the words and compute the extended location * information. The map first contain full per-word line @@ -1823,6 +1819,9 @@ CompileCommandTokens( envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; + if (expand && !cmdPtr) { + StartExpanding(envPtr); + } if (cmdPtr) { int savedNumCmds = envPtr->numCommands; int update = 0; -- cgit v0.12 From edb7dfc419cc7a8a06ed06669400e1e192a47c09 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 15:00:02 +0000 Subject: Consolidate the StartExpanding() calls. --- generic/tclCompile.c | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 0dc30e2..cbb93d9 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1819,9 +1819,6 @@ CompileCommandTokens( envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; - if (expand && !cmdPtr) { - StartExpanding(envPtr); - } if (cmdPtr) { int savedNumCmds = envPtr->numCommands; int update = 0; @@ -1919,11 +1916,10 @@ CompileCommandTokens( envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; + } - /* TODO: Can this happen? If so, is this right? */ - if (expand) { - StartExpanding(envPtr); - } + if (expand) { + StartExpanding(envPtr); } /* -- cgit v0.12 From d8459f08677700f376c5e39328895bd98bb5d7d1 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 15:24:56 +0000 Subject: Defer expansion request detection as much as possible. --- generic/tclCompile.c | 43 ++++++++++++++++++++++++++++++------------- 1 file changed, 30 insertions(+), 13 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cbb93d9..052dc8e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1744,6 +1744,22 @@ FindCompiledCommandFromToken( */ #ifdef REWRITE + +static int +ExpandRequested( + Tcl_Token *tokenPtr, + int numWords) +{ + /* Determine whether any words of the command require expansion */ + while (numWords--) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + return 1; + } + tokenPtr += tokenPtr->numComponents + 1; + } + return 0; +} + static int CompileCommandTokens( Tcl_Interp *interp, @@ -1755,7 +1771,7 @@ CompileCommandTokens( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; Tcl_Obj *cmdObj = Tcl_NewObj(); Command *cmdPtr = NULL; - int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; + int wordIdx, cmdKnown, expand = -1, numWords = parsePtr->numWords; int *wlines, wlineat; int cmdLine = envPtr->line; int *clNext = envPtr->clNext; @@ -1763,15 +1779,6 @@ CompileCommandTokens( int startCodeOffset = envPtr->codeNext - envPtr->codeStart; assert (numWords > 0); - - /* Determine whether any words of the command require expansion */ - for (wordIdx = 0; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - break; - } - } /* Do we know the command word? */ Tcl_IncrRefCount(cmdObj); @@ -1783,13 +1790,19 @@ CompileCommandTokens( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if (cmdPtr) { /* - * Found a command. Test all the ways we can be told + * Found a command. Test the ways we can be told * not to attempt to compile it. */ if ((cmdPtr->compileProc == NULL) || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) - || (cmdPtr->flags & CMD_HAS_EXEC_TRACES) - || (expand && !(cmdPtr->flags & CMD_COMPILES_EXPANDED))) { + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + cmdPtr = NULL; + } + } + if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + if (expand) { + /* We need to expand, but compileProc cannot. */ cmdPtr = NULL; } } @@ -1918,6 +1931,10 @@ CompileCommandTokens( envPtr->clNext = eclPtr->loc[wlineat].next[0]; } + if (expand < 0) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + } + if (expand) { StartExpanding(envPtr); } -- cgit v0.12 From c5f6c28026fcea560f1ca456c9ac4f8b7239e902 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 15:39:55 +0000 Subject: Move TIP 280 and command extent housekeeping to the periphery. --- generic/tclCompile.c | 54 ++++++++++++++++++++++++++-------------------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 052dc8e..388b8a0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1780,6 +1780,29 @@ CompileCommandTokens( assert (numWords > 0); + /* Pre-Compile */ + + envPtr->numCommands++; + EnterCmdStartData(envPtr, cmdIdx, + parsePtr->commandStart - envPtr->source, startCodeOffset); + + /* + * TIP #280. Scan the words and compute the extended location + * information. The map first contain full per-word line + * information for use by the compiler. This is later replaced by + * a reduced form which signals non-literal words, stored in + * 'wlines'. + */ + + EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, + parsePtr->tokenPtr, parsePtr->commandStart, + parsePtr->commandSize, parsePtr->numWords, cmdLine, + clNext, &wlines, envPtr); + wlineat = eclPtr->nuloc - 1; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + /* Do we know the command word? */ Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; @@ -1809,29 +1832,6 @@ CompileCommandTokens( } /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ - /* Pre-Compile */ - - envPtr->numCommands++; - EnterCmdStartData(envPtr, cmdIdx, - parsePtr->commandStart - envPtr->source, startCodeOffset); - - /* - * TIP #280. Scan the words and compute the extended location - * information. The map first contain full per-word line - * information for use by the compiler. This is later replaced by - * a reduced form which signals non-literal words, stored in - * 'wlines'. - */ - - EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->commandSize, parsePtr->numWords, cmdLine, - clNext, &wlines, envPtr); - wlineat = eclPtr->nuloc - 1; - - envPtr->line = eclPtr->loc[wlineat].line[0]; - envPtr->clNext = eclPtr->loc[wlineat].next[0]; - if (cmdPtr) { int savedNumCmds = envPtr->numCommands; int update = 0; @@ -2031,15 +2031,15 @@ CompileCommandTokens( } finishCommand: + if (cmdKnown) { + Tcl_DecrRefCount(cmdObj); + } + TclEmitOpcode(INST_POP, envPtr); EnterCmdExtentData(envPtr, cmdIdx, parsePtr->term - parsePtr->commandStart, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - if (cmdKnown) { - Tcl_DecrRefCount(cmdObj); - } - /* * TIP #280: Free full form of per-word line data and insert the * reduced form now -- cgit v0.12 From d668a84e6108d23992a0dcfa20714ce1c4be3037 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 18:08:01 +0000 Subject: Plug memory leak; Break three compilation mechanisms into routines. --- generic/tclCompile.c | 462 +++++++++++++++++++++++++++++---------------------- 1 file changed, 266 insertions(+), 196 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 388b8a0..1958d47 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1760,6 +1760,255 @@ ExpandRequested( return 0; } +static void +CompileInvocation( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + int wlineat, + CompileEnv *envPtr) +{ + int isnew, wordIdx = 0; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + + if (cmdObj) { + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), + cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); + + wordIdx = 1; + tokenPtr += tokenPtr->numComponents + 1; + } + + for (; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + int objIdx; + + envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, + eclPtr->loc[wlineat].next[wordIdx]); + } + TclEmitPush(objIdx, envPtr); + } + + /* + * Save PC -> command map for the TclArgumentBC* functions. + */ + + Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, + INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew), + INT2PTR(wlineat)); + + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } +} + +static void +CompileExpanded( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + int wlineat, + CompileEnv *envPtr) +{ + int wordIdx = 0; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + + StartExpanding(envPtr); + if (cmdObj) { + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, + TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); + + wordIdx = 1; + tokenPtr += tokenPtr->numComponents + 1; + } + + for (; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + int objIdx; + + envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, + eclPtr->loc[wlineat].next[wordIdx]); + } + TclEmitPush(objIdx, envPtr); + } + + /* + * The stack depth during argument expansion can only be + * managed at runtime, as the number of elements in the + * expanded lists is not known at compile time. We adjust here + * the stack depth estimate so that it is correct after the + * command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the + * words of the command are popped from the stack, and the + * result is pushed: the stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command + * is being prepared and run, INST_EXPAND_STKTOP is not + * stack-neutral in general. + */ + + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - wordIdx, envPtr); +} + +static int +CompileCmdCompileProc( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, + int startCodeOffset, + CompileEnv *envPtr) +{ + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + int savedNumCmds = envPtr->numCommands; + int startStackDepth = envPtr->currStackDepth; + int wlineat = eclPtr->nuloc - 1; + int update = 0; + + /* + * Mark the start of the command; the proper bytecode + * length will be updated later. There is no need to + * do this for the first bytecode in the compile env, + * as the check is done before calling + * TclNRExecuteByteCode(). Do emit an INST_START_CMD + * in special cases where the first bytecode is in a + * loop, to insure that the corresponding command is + * counted properly. Compilers for commands able to + * produce such a beast (currently 'while 1' only) set + * envPtr->atCmdStart to 0 in order to signal this + * case. [Bug 1752146] + * + * Note that the environment is initialised with + * atCmdStart=1 to avoid emitting ISC for the first + * command. + */ + + if (envPtr->atCmdStart == 1) { + if (startCodeOffset) { + /* + * Increase the number of commands being + * started at the current point. Note that + * this depends on the exact layout of the + * INST_START_CMD's operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) + } + } else if (envPtr->atCmdStart == 0) { + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + TclEmitInt4(1, envPtr); + update = 1; + } + + if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { + +#ifdef TCL_COMPILE_DEBUG + /* + * Confirm that the command compiler generated a + * single value on the stack as its result. This + * is only done in debugging mode, as it *should* + * be correct and normal users have no reasonable + * way to fix it anyway. + */ + + int diff = envPtr->currStackDepth - startStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif + if (update) { + /* + * Fix the bytecode length. + */ + + unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; + unsigned fixLen = envPtr->codeNext - fixPtr + 1; + + TclStoreInt4AtPtr(fixLen, fixPtr); + } + return TCL_OK; + } + + if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { + /* + * Decrease the number of commands being started + * at the current point. Note that this depends on + * the exact layout of the INST_START_CMD's + * operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); + } + + /* + * Restore numCommands, codeNext, and currStackDepth to their + * correct values, removing any commands compiled before the + * failure to produce bytecode got reported. + * [Bugs 705406, 735055, 3614102] + */ + + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart + startCodeOffset; + envPtr->currStackDepth = startStackDepth; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + return TCL_ERROR; +} + static int CompileCommandTokens( Tcl_Interp *interp, @@ -1771,14 +2020,15 @@ CompileCommandTokens( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; Tcl_Obj *cmdObj = Tcl_NewObj(); Command *cmdPtr = NULL; - int wordIdx, cmdKnown, expand = -1, numWords = parsePtr->numWords; + int code = TCL_ERROR; + int cmdKnown, expand = -1; int *wlines, wlineat; int cmdLine = envPtr->line; int *clNext = envPtr->clNext; int cmdIdx = envPtr->numCommands; int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - assert (numWords > 0); + assert (parsePtr->numWords > 0); /* Pre-Compile */ @@ -1830,210 +2080,30 @@ CompileCommandTokens( } } } - /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ + /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ if (cmdPtr) { - int savedNumCmds = envPtr->numCommands; - int update = 0; - int startStackDepth = envPtr->currStackDepth; - - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD - * in special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] - * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. - */ - - if (envPtr->atCmdStart == 1) { - if (startCodeOffset) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) - } - } else if (envPtr->atCmdStart == 0) { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; - } - - if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { - -#ifdef TCL_COMPILE_DEBUG - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ - - int diff = envPtr->currStackDepth - startStackDepth; - - if (diff != 1) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", - parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif - if (update) { - /* - * Fix the bytecode length. - */ - - unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; - unsigned fixLen = envPtr->codeNext - fixPtr + 1; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } - - if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); - } - - /* - * Restore numCommands, codeNext, and currStackDepth to their - * correct values, removing any commands compiled before the - * failure to produce bytecode got reported. - * [Bugs 705406, 735055, 3614102] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + startCodeOffset; - envPtr->currStackDepth = startStackDepth; - - envPtr->line = eclPtr->loc[wlineat].line[0]; - envPtr->clNext = eclPtr->loc[wlineat].next[0]; - } - - if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); - } - - if (expand) { - StartExpanding(envPtr); - } - - /* - * No complile attempted, or it failed. - * Need to emit instructions to invoke, with expansion if needed. - */ - - wordIdx = 0; - tokenPtr = parsePtr->tokenPtr; - if (cmdKnown) { - int cmdLitIdx, numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - - cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - if (cmdPtr) { - TclSetCmdNameObj(interp, - TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); - } - TclEmitPush(cmdLitIdx, envPtr); - - wordIdx = 1; - tokenPtr += tokenPtr->numComponents + 1; + code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, + startCodeOffset, envPtr); } - for (; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - int objIdx; - - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - CompileTokens(envPtr, tokenPtr, interp); - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } - - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (envPtr->clNext) { - TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); + if (code == TCL_ERROR) { + if (expand < 0) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); } - TclEmitPush(objIdx, envPtr); - } - - /* - * Emit an invoke instruction for the command. We skip this if a - * compile procedure was found for the command. - */ - if (expand) { - /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. - * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). - * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. - */ - - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - envPtr->expandCount--; - TclAdjustStackDepth(1 - wordIdx, envPtr); - } else { - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ - - int isnew; - Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew); - - Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); - if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + if (expand) { + CompileExpanded(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, + envPtr); } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + CompileInvocation(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, + envPtr); } } -finishCommand: - if (cmdKnown) { - Tcl_DecrRefCount(cmdObj); - } + Tcl_DecrRefCount(cmdObj); TclEmitOpcode(INST_POP, envPtr); EnterCmdExtentData(envPtr, cmdIdx, -- cgit v0.12 From ae8d32e17d3ddc932def49dc45643928d7fe97ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Jul 2013 18:55:23 +0000 Subject: Unbreak MSVC6 debug build (thanks Andreas Kupries!) --- generic/tclUtf.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index a122685..a038f8a 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1554,7 +1554,7 @@ Tcl_UniCharIsSpace( */ if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { - return TclIsSpaceProc(ch); + return TclIsSpaceProc((char) ch); } else if ((Tcl_UniChar) ch == 0x180e) { return 1; } else { -- cgit v0.12 From 8127bc5dd162ce6a44aa4bdcb28f378ae8663514 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 19:29:01 +0000 Subject: Factor out compiling the Command literal. --- generic/tclCompile.c | 41 +++++++++++++++++++---------------------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1958d47..a1ad5c8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1761,6 +1761,23 @@ ExpandRequested( } static void +CompileCmdLiteral( + Tcl_Interp *interp, + Tcl_Obj *cmdObj, + CompileEnv *envPtr) +{ + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); +} + +static void CompileInvocation( Tcl_Interp *interp, Tcl_Token *tokenPtr, @@ -1773,17 +1790,7 @@ CompileInvocation( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; if (cmdObj) { - int numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - - if (cmdPtr) { - TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), - cmdPtr); - } - TclEmitPush(cmdLitIdx, envPtr); - + CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; tokenPtr += tokenPtr->numComponents + 1; } @@ -1839,17 +1846,7 @@ CompileExpanded( StartExpanding(envPtr); if (cmdObj) { - int numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - - if (cmdPtr) { - TclSetCmdNameObj(interp, - TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); - } - TclEmitPush(cmdLitIdx, envPtr); - + CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; tokenPtr += tokenPtr->numComponents + 1; } -- cgit v0.12 From 13eca0490a3b888d3858a8a27f12a779d4a8235f Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 22:36:55 +0000 Subject: Use TIP 280 macros. --- generic/tclCompile.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a1ad5c8..656f700 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1906,11 +1906,10 @@ CompileCmdCompileProc( int startCodeOffset, CompileEnv *envPtr) { - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int savedNumCmds = envPtr->numCommands; int startStackDepth = envPtr->currStackDepth; - int wlineat = eclPtr->nuloc - 1; int update = 0; + DefineLineInformation; /* * Mark the start of the command; the proper bytecode @@ -2001,8 +2000,7 @@ CompileCmdCompileProc( envPtr->codeNext = envPtr->codeStart + startCodeOffset; envPtr->currStackDepth = startStackDepth; - envPtr->line = eclPtr->loc[wlineat].line[0]; - envPtr->clNext = eclPtr->loc[wlineat].next[0]; + SetLineInformation(0); return TCL_ERROR; } -- cgit v0.12 From 05741eb1bdedbef1fd4b526cd8ddd3f887d59490 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 23:02:44 +0000 Subject: Use the TokenAfter() macro. --- generic/tclCompile.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 656f700..afe34b0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1755,7 +1755,7 @@ ExpandRequested( if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { return 1; } - tokenPtr += tokenPtr->numComponents + 1; + tokenPtr = TokenAfter(tokenPtr); } return 0; } @@ -1792,11 +1792,10 @@ CompileInvocation( if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; - tokenPtr += tokenPtr->numComponents + 1; + tokenPtr = TokenAfter(tokenPtr); } - for (; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; @@ -1848,11 +1847,10 @@ CompileExpanded( if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; - tokenPtr += tokenPtr->numComponents + 1; + tokenPtr = TokenAfter(tokenPtr); } - for (; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; -- cgit v0.12 From c2d2ec2ecab6696829da18c4e7174a90e42f9138 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 9 Jul 2013 20:37:37 +0000 Subject: Tentative Work In Progress unwinding TIP 280 line information. --- generic/tclCompile.c | 39 +++++++++++++++++++++++++++++---------- 1 file changed, 29 insertions(+), 10 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index afe34b0..777c03e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1787,7 +1787,8 @@ CompileInvocation( CompileEnv *envPtr) { int isnew, wordIdx = 0; - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; +// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + DefineLineInformation; if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -1798,8 +1799,9 @@ CompileInvocation( for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; +// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; +// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + SetLineInformation(wordIdx); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); @@ -1811,7 +1813,8 @@ CompileInvocation( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); +// eclPtr->loc[wlineat].next[wordIdx]); + mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); } @@ -1820,9 +1823,11 @@ CompileInvocation( * Save PC -> command map for the TclArgumentBC* functions. */ - Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, +// Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, + Tcl_SetHashValue(Tcl_CreateHashEntry(&mapPtr->litInfo, INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew), - INT2PTR(wlineat)); +// INT2PTR(wlineat)); + INT2PTR(eclIndex)); if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); @@ -1841,7 +1846,9 @@ CompileExpanded( CompileEnv *envPtr) { int wordIdx = 0; - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + DefineLineInformation; +// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + StartExpanding(envPtr); if (cmdObj) { @@ -1853,8 +1860,9 @@ CompileExpanded( for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + SetLineInformation(wordIdx); +// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; +// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); @@ -1870,7 +1878,8 @@ CompileExpanded( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); +// eclPtr->loc[wlineat].next[wordIdx]); + mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); } @@ -1998,6 +2007,16 @@ CompileCmdCompileProc( envPtr->codeNext = envPtr->codeStart + startCodeOffset; envPtr->currStackDepth = startStackDepth; + /* + * Throw out any line information generated by the failed + * compile attempt. + */ + while (mapPtr->nuloc - 1 > eclIndex) { + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; + } + SetLineInformation(0); return TCL_ERROR; } -- cgit v0.12 From ea62135f72eea3a5096735196d59c2b6785e942e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 03:17:57 +0000 Subject: Revise the litInfo table so that it gets built later (in TclInitByteCodeObj) from a simpler store of data that can unwind. --- generic/tclCompile.c | 79 +++++++++++++--------------------------------------- generic/tclCompile.h | 1 + 2 files changed, 20 insertions(+), 60 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 777c03e..c31d256 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1786,8 +1786,7 @@ CompileInvocation( int wlineat, CompileEnv *envPtr) { - int isnew, wordIdx = 0; -// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + int wordIdx = 0; DefineLineInformation; if (cmdObj) { @@ -1799,8 +1798,6 @@ CompileInvocation( for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; -// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; -// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; SetLineInformation(wordIdx); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -1813,7 +1810,6 @@ CompileInvocation( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, -// eclPtr->loc[wlineat].next[wordIdx]); mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); @@ -1823,11 +1819,7 @@ CompileInvocation( * Save PC -> command map for the TclArgumentBC* functions. */ -// Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, - Tcl_SetHashValue(Tcl_CreateHashEntry(&mapPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew), -// INT2PTR(wlineat)); - INT2PTR(eclIndex)); + mapPtr->loc[eclIndex].invokePc = envPtr->codeNext - envPtr->codeStart; if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); @@ -1847,7 +1839,6 @@ CompileExpanded( { int wordIdx = 0; DefineLineInformation; -// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; StartExpanding(envPtr); @@ -1861,8 +1852,6 @@ CompileExpanded( int objIdx; SetLineInformation(wordIdx); -// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; -// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); @@ -1878,7 +1867,6 @@ CompileExpanded( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, -// eclPtr->loc[wlineat].next[wordIdx]); mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); @@ -2015,6 +2003,7 @@ CompileCmdCompileProc( mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; + mapPtr->loc[mapPtr->nuloc].invokePc = -1; } SetLineInformation(0); @@ -3340,6 +3329,17 @@ TclInitByteCodeObj( * byte code object (internal rep), for use with the bc compiler. */ + for (i = 0; i < envPtr->extCmdMapPtr->nuloc; i++) { + int isnew, pc = envPtr->extCmdMapPtr->loc[i].invokePc; + + if (pc < 0) { + continue; + } + + Tcl_SetHashValue(Tcl_CreateHashEntry(&envPtr->extCmdMapPtr->litInfo, + INT2PTR(pc), &isnew), INT2PTR(i)); + } + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr, &isNew), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; @@ -3710,6 +3710,7 @@ EnterCmdWordData( ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; + ePtr->invokePc = -1; ePtr->line = ckalloc(numWords * sizeof(int)); ePtr->next = ckalloc(numWords * sizeof(int *)); ePtr->nline = numWords; @@ -4493,54 +4494,12 @@ TclFixupForwardJump( { ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; - - /* A helper structure */ - - typedef struct { - int pc; - int cmd; - } MAP; - - /* - * And the helper array. At most the whole hashtable is placed into - * this. - */ - - MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries); - - Tcl_HashSearch hSearch; - Tcl_HashEntry* hPtr; - int n, k, isnew; - - /* - * Phase I: Locate the affected entries, and save them in adjusted - * form to the array. This removes them from the hash. - */ - - for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - - map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr)); - map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr)); - - if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) { - Tcl_DeleteHashEntry(hPtr); - map [n].pc += 3; - n++; + for (k = eclPtr->nuloc - 1; k >= 0; k--) { + if (eclPtr->loc[k].invokePc < (jumpFixupPtr->codeOffset + 2)) { + continue; } + eclPtr->loc[k].invokePc += 3; } - - /* - * Phase II: Re-insert the modified entries into the hash. - */ - - for (k=0;klitInfo, INT2PTR(map[k].pc), &isnew); - Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); - } - - ckfree (map); } return 1; /* the jump was grown */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..cbe104c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -175,6 +175,7 @@ typedef struct CmdLocation { typedef struct ECL { int srcOffset; /* Command location to find the entry. */ + int invokePc; int nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ -- cgit v0.12 From 98b5a1b51d301f8712ef1dd7e9a321804d93ba02 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 03:28:37 +0000 Subject: Remove the (now unused) wlineat arguments. --- generic/tclCompile.c | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c31d256..5f4acff 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1783,7 +1783,6 @@ CompileInvocation( Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, - int wlineat, CompileEnv *envPtr) { int wordIdx = 0; @@ -1834,7 +1833,6 @@ CompileExpanded( Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, - int wlineat, CompileEnv *envPtr) { int wordIdx = 0; @@ -2095,12 +2093,10 @@ CompileCommandTokens( if (expand) { CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, - envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } else { CompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, - envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } } -- cgit v0.12 From 79cd9409e13c0854f7eb3f04d970e44b30c3ec7d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 16:17:12 +0000 Subject: Disabling the SetLineInformation() macro entirely causes only 3 tests in the test suite to fail. Restoring just 2 SetLineInformation() calls fixes those failures. The need for all the other SLI() calls is not demonstrated by any test. Without more complete test coverage, it is difficult to confidently tweak the TIP 280 implementation without fear that changes are introducing breakage. --- generic/tclCompCmdsGR.c | 2 ++ generic/tclCompCmdsSZ.c | 2 ++ generic/tclCompile.h | 9 ++++++--- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f7c15e6..3cd0da6 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -265,6 +265,8 @@ TclCompileIfCmd( if (compileScripts) { SetLineInformation(wordIdx); +envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; +envPtr->clNext = mapPtr->loc[eclIndex].next[wordIdx]; CompileBody(envPtr, tokenPtr, interp); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 855dd8f..8723a4f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -726,6 +726,8 @@ TclCompileSubstCmd( } SetLineInformation(numArgs); +envPtr->line = mapPtr->loc[eclIndex].line[numArgs]; +envPtr->clNext = mapPtr->loc[eclIndex].next[numArgs]; TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..6fe14f2 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1537,9 +1537,12 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] +//#define SetLineInformation(word) \ +// envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ +// envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] + +#define SetLineInformation(word) + #define PushVarNameWord(i,v,e,f,l,sc,word) \ TclPushVarName(i,v,e,f,l,sc, \ -- cgit v0.12 From 55deb86ee331985bbfedb4d5211968c4dbe1decd Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 16:27:09 +0000 Subject: First additional test. Remove dup macros in tclEnsemble.c. --- generic/tclCompCmds.c | 2 +- generic/tclCompCmdsGR.c | 4 +--- generic/tclCompCmdsSZ.c | 4 +--- generic/tclCompile.h | 6 +++--- generic/tclEnsemble.c | 10 ---------- tests/info.test | 15 +++++++++++++++ 6 files changed, 21 insertions(+), 20 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fddf152..7ed9006 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,7 +610,7 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - SetLineInformation(1); + LineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 3cd0da6..cc3f694 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -264,9 +264,7 @@ TclCompileIfCmd( */ if (compileScripts) { - SetLineInformation(wordIdx); -envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; -envPtr->clNext = mapPtr->loc[eclIndex].next[wordIdx]; + LineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8723a4f..34c24f9 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -725,9 +725,7 @@ TclCompileSubstCmd( return TCL_ERROR; } - SetLineInformation(numArgs); -envPtr->line = mapPtr->loc[eclIndex].line[numArgs]; -envPtr->clNext = mapPtr->loc[eclIndex].next[numArgs]; + LineInformation(numArgs); TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6fe14f2..5043f65 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1537,9 +1537,9 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 -//#define SetLineInformation(word) \ -// envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ -// envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] +#define LineInformation(word) \ + envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] #define SetLineInformation(word) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 813e056..e0aa0c4 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -88,16 +88,6 @@ const Tcl_ObjType tclEnsembleCmdType = { NULL /* setFromAnyProc */ }; -/* - * Copied from tclCompCmds.c - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] static inline Tcl_Obj * NewNsObj( diff --git a/tests/info.test b/tests/info.test index ebc853a..a1d3b1a 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1962,6 +1962,21 @@ test info-9.13 {info level option, value in global context} -body { } -returnCodes error -result {bad level "2"} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + catch {*}{ + {info frame 0} + res + } + return $res +} +test info-33.4 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From acd32d6e7090b829a7d5e1aec2e6b09f987aaccc Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 16:43:01 +0000 Subject: Next attempt. Appears to have uncovered a bug. --- generic/tclCompCmds.c | 2 +- tests/info.test | 14 ++++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7ed9006..13318a3 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1467,7 +1467,7 @@ CompileDictEachCmd( * Compile the loop body itself. It should be stack-neutral. */ - SetLineInformation(3); + LineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); diff --git a/tests/info.test b/tests/info.test index a1d3b1a..ba31159 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1977,6 +1977,20 @@ test info-33.4 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + dict for {a b} {c d} {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.5 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From fceaf9997d7c45ba92c6c61930207823446f1e50 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 17:58:45 +0000 Subject: Fix for [86fb5ea28e]. Test will eventually merge in from tip280-test-coverage. --- generic/tclEnsemble.c | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 813e056..a718d0e 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3059,6 +3059,7 @@ CompileToCompiledCommand( int savedNumCmds = envPtr->numCommands; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; + DefineLineInformation; if (cmdPtr->compileProc == NULL) { return TCL_ERROR; @@ -3107,12 +3108,27 @@ CompileToCompiledCommand( } /* + * Shift the line information arrays to account for different word + * index values. + */ + + mapPtr->loc[eclIndex].line += (depth - 1); + mapPtr->loc[eclIndex].next += (depth - 1); + + /* * Hand off compilation to the subcommand compiler. At last! */ result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); /* + * Undo the shift. + */ + + mapPtr->loc[eclIndex].line -= (depth - 1); + mapPtr->loc[eclIndex].next -= (depth - 1); + + /* * If our target fails to compile, revert the number of commands and the * pointer to the place to issue the next instruction. [Bug 3600328] */ -- cgit v0.12 From 6f87f7f3302077aa68a48258e328bbf2ee5abd51 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 19:34:55 +0000 Subject: Add tests for, and fix bugs in, the SetLineInformation() calls in tclCompCmds.c. --- generic/tclCompCmds.c | 20 ++++----- tests/info.test | 118 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 127 insertions(+), 11 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 13318a3..28a3e64 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1651,7 +1651,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords - 1); + LineInformation(parsePtr->numWords - 1); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -1992,7 +1992,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords-1); + LineInformation(parsePtr->numWords-1); CompileBody(envPtr, tokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -2268,7 +2268,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - SetLineInformation(1); + LineInformation(1); CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); @@ -2292,7 +2292,7 @@ TclCompileForCmd( bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - SetLineInformation(4); + LineInformation(4); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); TclEmitOpcode(INST_POP, envPtr); @@ -2306,7 +2306,7 @@ TclCompileForCmd( nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - SetLineInformation(3); + LineInformation(3); CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, envPtr); @@ -2325,7 +2325,7 @@ TclCompileForCmd( testCodeOffset += 3; } - SetLineInformation(2); + LineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; @@ -2464,7 +2464,7 @@ CompileEachloopCmd( Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex; + int jumpBackDist, jumpBackOffset, infoIndex, range; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; DefineLineInformation; /* TIP #280 */ @@ -2504,8 +2504,6 @@ CompileEachloopCmd( return TCL_ERROR; } - bodyIndex = i-1; - /* * Allocate storage for the varcList and varvList arrays if necessary. */ @@ -2646,7 +2644,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - SetLineInformation(i); + LineInformation(i); CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); @@ -2684,7 +2682,7 @@ CompileEachloopCmd( * Inline compile the loop body. */ - SetLineInformation(bodyIndex); + LineInformation(numWords - 1); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); diff --git a/tests/info.test b/tests/info.test index ba31159..98bb724 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1991,6 +1991,124 @@ test info-33.5 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {a b} + dict update d x y {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.6 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {} + dict with d {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.7 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {set res [info frame 0]} + {1} {} {break} + } + return $res +} +test info-33.8 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} {} + {set res [info frame 0]; break} + } + return $res +} +test info-33.9 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} + {return [info frame 0]} + {} + } +} +test info-33.10 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} + {[return [info frame 0]]} + {} {} + } +} +test info-33.11 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x + } [return [info frame 0]] {} +} +test info-33.12 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x y + {set res [info frame 0]} + } + return $res +} +test info-33.13 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From ef77c88392ff7b5d78b792b9d684a4ba30d175cc Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 19:43:56 +0000 Subject: Add tests for SetLineInformation() calls in tclCompCmdsGR.c. --- generic/tclCompCmdsGR.c | 8 ++++---- tests/info.test | 53 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index cc3f694..32514ab 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -222,7 +222,7 @@ TclCompileIfCmd( compileScripts = 0; } } else { - SetLineInformation(wordIdx); + LineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { @@ -345,7 +345,7 @@ TclCompileIfCmd( * Compile the else command body. */ - SetLineInformation(wordIdx); + LineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } @@ -474,7 +474,7 @@ TclCompileIncrCmd( PushLiteral(envPtr, word, numBytes); } } else { - SetLineInformation(2); + LineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1. */ @@ -701,7 +701,7 @@ TclCompileInfoLevelCmd( * list of arguments. */ - SetLineInformation(1); + LineInformation(1); CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } diff --git a/tests/info.test b/tests/info.test index 98bb724..98f6ea7 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2109,6 +2109,59 @@ test info-33.13 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if {*}{ + {[return [info frame 0]]} + {} + } +} +test info-33.14 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if 0 {*}{ + {} else + {return [info frame 0]} + } +} +test info-33.15 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + incr {*}{ + x + } [return [info frame 0]] +} +test info-33.16 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + info level {*}{ + } [return [info frame 0]] +} +test info-33.16 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From fe3f5136f96353b1b0d77700e4c4ef6256eb1e55 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 20:33:45 +0000 Subject: Add tests for SetLineInformation() calls in tclCompCmdsSZ.c as well as some obvious refactoring improvements. --- generic/tclCompCmdsSZ.c | 66 ++++++----------- tests/info.test | 186 +++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 206 insertions(+), 46 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 34c24f9..d5208e6 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -40,17 +40,14 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static void IssueSwitchChainedTests(Tcl_Interp *interp, - CompileEnv *envPtr, ExtCmdLoc *mapPtr, - int eclIndex, int mode, int noCase, - int valueIndex, Tcl_Token *valueTokenPtr, - int numWords, Tcl_Token **bodyToken, - int *bodyLines, int **bodyNext); -static void IssueSwitchJumpTable(Tcl_Interp *interp, - CompileEnv *envPtr, ExtCmdLoc *mapPtr, - int eclIndex, int valueIndex, - Tcl_Token *valueTokenPtr, int numWords, + CompileEnv *envPtr, int mode, int noCase, + int valueIndex, int numWords, Tcl_Token **bodyToken, int *bodyLines, - int **bodyContLines); + int **bodyNext); +static void IssueSwitchJumpTable(Tcl_Interp *interp, + CompileEnv *envPtr, int valueIndex, + int numWords, Tcl_Token **bodyToken, + int *bodyLines, int **bodyContLines); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, @@ -89,7 +86,7 @@ const AuxDataType tclJumptableInfoType = { #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define BODY(token,index) \ - SetLineInformation((index));CompileBody(envPtr,(token),interp) + LineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ PushStringLiteral(envPtr, str) #define JUMP4(name,var) \ @@ -436,7 +433,7 @@ TclCompileStringMatchCmd( } PushLiteral(envPtr, str, length); } else { - SetLineInformation(i+1+nocase); + LineInformation(i+1+nocase); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); @@ -486,7 +483,7 @@ TclCompileStringLenCmd( len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { - SetLineInformation(1); + LineInformation(1); CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_STR_LEN, envPtr); } @@ -1286,13 +1283,16 @@ TclCompileSwitchCmd( * but it handles the most common case well enough. */ + /* Both methods push the value to match against onto the stack. */ + LineInformation(valueIndex); + CompileTokens(envPtr, valueTokenPtr, interp); + if (mode == Switch_Exact) { - IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex, - valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines); + IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken, + bodyLines, bodyContLines); } else { - IssueSwitchChainedTests(interp, envPtr, mapPtr, eclIndex, mode,noCase, - valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines, - bodyContLines); + IssueSwitchChainedTests(interp, envPtr, mode, noCase, valueIndex, + numWords, bodyToken, bodyLines, bodyContLines); } result = TCL_OK; @@ -1330,13 +1330,9 @@ static void IssueSwitchChainedTests( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - ExtCmdLoc *mapPtr, /* For mapping tokens to their source code - * location. */ - int eclIndex, int mode, /* Exact, Glob or Regexp */ int noCase, /* Case-insensitivity flag. */ int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ @@ -1361,13 +1357,6 @@ IssueSwitchChainedTests( int i; /* - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* * Generate a test for each arm. */ @@ -1592,11 +1581,7 @@ static void IssueSwitchJumpTable( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - ExtCmdLoc *mapPtr, /* For mapping tokens to their source code - * location. */ - int eclIndex, int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ @@ -1612,13 +1597,6 @@ IssueSwitchJumpTable( Tcl_HashEntry *hPtr; /* - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* * Compile the switch by using a jump table, which is basically a * hashtable that maps from literal values to match against to the offset * (relative to the INST_JUMP_TABLE instruction) to jump to. The jump @@ -2048,8 +2026,7 @@ TclCompileTryCmd( */ DefineLineInformation; /* TIP #280 */ - SetLineInformation(1); - CompileBody(envPtr, bodyToken, interp); + BODY(bodyToken, 1); return TCL_OK; } @@ -3028,13 +3005,12 @@ TclCompileWhileCmd( * Compile the loop body. */ - SetLineInformation(2); bodyCodeOffset = ExceptionRangeStarts(envPtr, range); if (!loopMayEnd) { envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; } - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 2); ExceptionRangeEnds(envPtr, range); OP( POP); @@ -3050,7 +3026,7 @@ TclCompileWhileCmd( bodyCodeOffset += 3; testCodeOffset += 3; } - SetLineInformation(1); + LineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; diff --git a/tests/info.test b/tests/info.test index 98f6ea7..a68fb43 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2155,13 +2155,197 @@ proc foo::bar {} { info level {*}{ } [return [info frame 0]] } -test info-33.16 {{*}, literal, simple, bytecompiled} -body { +test info-33.17 {{*}, literal, simple, bytecompiled} -body { reduce [foo::bar] } -cleanup { namespace delete foo } -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + } [return [info frame 0]] {} +} +test info-33.18 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + {} + } [return [info frame 0]] +} +test info-33.19 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string length {*}{ + } [return [info frame 0]] +} +test info-33.20 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while {*}{ + {[return [info frame 0]]} + } {} +} +test info-33.21 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + switch -- {*}{ + } [return [info frame 0]] {*}{ + } x y +} +test info-33.22 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.23 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } finally {} + return $res +} +test info-33.24 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} + return $res +} +test info-33.25 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} finally {} + return $res +} +test info-33.26 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while 1 {*}{ + {return [info frame 0]} + } +} +test info-33.27 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.28 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.29 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } +} +test info-33.30 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } finally {} +} +test info-33.31 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From f3a1a26516d79b15224325941f72deb7dfda25f6 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 03:48:40 +0000 Subject: Add tests for the SetLineInformation() calls in tclEnsemble.c, and fix the bugs around those calls exposed by the tests. --- generic/tclEnsemble.c | 9 +++------ tests/info.test | 25 +++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 6 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index d654bbf..794a059 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3168,6 +3168,7 @@ CompileToInvokedCommand( bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* TODO: Check about registering Cmd Literals here */ int literal = TclRegisterNewLiteral(envPtr, tokPtr[1].start, tokPtr[1].size); @@ -3179,9 +3180,7 @@ CompileToInvokedCommand( } TclEmitPush(literal, envPtr); } else { - if (envPtr->clNext) { - SetLineInformation(i); - } + LineInformation(i); CompileTokens(envPtr, tokPtr, interp); } tokPtr = TokenAfter(tokPtr); @@ -3255,12 +3254,10 @@ CompileBasicNArgCommand( tokenPtr = TokenAfter(parsePtr->tokenPtr); for (i=1 ; inumWords ; i++) { - if (envPtr->clNext) { - SetLineInformation(i); - } if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); } else { + LineInformation(i); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); diff --git a/tests/info.test b/tests/info.test index a68fb43..afdaaee 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2346,6 +2346,31 @@ test info-33.31 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + binary format {*}{ + } [return [info frame 0]] +} +test info-33.32 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set format format + binary $format {*}{ + } [return [info frame 0]] +} +test info-33.33 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From ac62d0c4970dfe3fa03f4fa77c05d23943a20671 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 04:00:57 +0000 Subject: Revert the revised macros used in developing the new tests. --- generic/tclCompCmds.c | 20 ++++++++++---------- generic/tclCompCmdsGR.c | 10 +++++----- generic/tclCompCmdsSZ.c | 12 ++++++------ generic/tclCompile.h | 5 +---- generic/tclEnsemble.c | 4 ++-- 5 files changed, 24 insertions(+), 27 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 28a3e64..a56727d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,7 +610,7 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - LineInformation(1); + SetLineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -1467,7 +1467,7 @@ CompileDictEachCmd( * Compile the loop body itself. It should be stack-neutral. */ - LineInformation(3); + SetLineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); @@ -1651,7 +1651,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - LineInformation(parsePtr->numWords - 1); + SetLineInformation(parsePtr->numWords - 1); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -1992,7 +1992,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - LineInformation(parsePtr->numWords-1); + SetLineInformation(parsePtr->numWords-1); CompileBody(envPtr, tokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -2268,7 +2268,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - LineInformation(1); + SetLineInformation(1); CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); @@ -2292,7 +2292,7 @@ TclCompileForCmd( bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - LineInformation(4); + SetLineInformation(4); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); TclEmitOpcode(INST_POP, envPtr); @@ -2306,7 +2306,7 @@ TclCompileForCmd( nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - LineInformation(3); + SetLineInformation(3); CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, envPtr); @@ -2325,7 +2325,7 @@ TclCompileForCmd( testCodeOffset += 3; } - LineInformation(2); + SetLineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; @@ -2644,7 +2644,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - LineInformation(i); + SetLineInformation(i); CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); @@ -2682,7 +2682,7 @@ CompileEachloopCmd( * Inline compile the loop body. */ - LineInformation(numWords - 1); + SetLineInformation(numWords - 1); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 32514ab..f7c15e6 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -222,7 +222,7 @@ TclCompileIfCmd( compileScripts = 0; } } else { - LineInformation(wordIdx); + SetLineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { @@ -264,7 +264,7 @@ TclCompileIfCmd( */ if (compileScripts) { - LineInformation(wordIdx); + SetLineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } @@ -345,7 +345,7 @@ TclCompileIfCmd( * Compile the else command body. */ - LineInformation(wordIdx); + SetLineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } @@ -474,7 +474,7 @@ TclCompileIncrCmd( PushLiteral(envPtr, word, numBytes); } } else { - LineInformation(2); + SetLineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1. */ @@ -701,7 +701,7 @@ TclCompileInfoLevelCmd( * list of arguments. */ - LineInformation(1); + SetLineInformation(1); CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d5208e6..0497e8a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -86,7 +86,7 @@ const AuxDataType tclJumptableInfoType = { #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define BODY(token,index) \ - LineInformation((index));CompileBody(envPtr,(token),interp) + SetLineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ PushStringLiteral(envPtr, str) #define JUMP4(name,var) \ @@ -433,7 +433,7 @@ TclCompileStringMatchCmd( } PushLiteral(envPtr, str, length); } else { - LineInformation(i+1+nocase); + SetLineInformation(i+1+nocase); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); @@ -483,7 +483,7 @@ TclCompileStringLenCmd( len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { - LineInformation(1); + SetLineInformation(1); CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_STR_LEN, envPtr); } @@ -722,7 +722,7 @@ TclCompileSubstCmd( return TCL_ERROR; } - LineInformation(numArgs); + SetLineInformation(numArgs); TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); @@ -1284,7 +1284,7 @@ TclCompileSwitchCmd( */ /* Both methods push the value to match against onto the stack. */ - LineInformation(valueIndex); + SetLineInformation(valueIndex); CompileTokens(envPtr, valueTokenPtr, interp); if (mode == Switch_Exact) { @@ -3026,7 +3026,7 @@ TclCompileWhileCmd( bodyCodeOffset += 3; testCodeOffset += 3; } - LineInformation(1); + SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5043f65..9af4911 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1537,13 +1537,10 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 -#define LineInformation(word) \ +#define SetLineInformation(word) \ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] -#define SetLineInformation(word) - - #define PushVarNameWord(i,v,e,f,l,sc,word) \ TclPushVarName(i,v,e,f,l,sc, \ mapPtr->loc[eclIndex].line[(word)], \ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 794a059..0bb7cb6 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3180,7 +3180,7 @@ CompileToInvokedCommand( } TclEmitPush(literal, envPtr); } else { - LineInformation(i); + SetLineInformation(i); CompileTokens(envPtr, tokPtr, interp); } tokPtr = TokenAfter(tokPtr); @@ -3257,7 +3257,7 @@ CompileBasicNArgCommand( if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); } else { - LineInformation(i); + SetLineInformation(i); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); -- cgit v0.12 From 6da16cce5001da699a5d43e075eaf706b8d68d63 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 17:06:35 +0000 Subject: Have TclMakeEnsemble() set ENSEMBLE_COMPILE at creation, not as a separate epoch-bumping step. --- generic/tclEnsemble.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 0bb7cb6..680ab45d 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1527,6 +1527,14 @@ TclMakeEnsemble( cmdName = nameParts[nameCount - 1]; } } + + /* + * Switch on compilation always for core ensembles now that we can do + * nice bytecode things with them. Do it now. Waiting until later will + * just cause pointless epoch bumps. + */ + + ensembleFlags |= ENSEMBLE_COMPILE; ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags); /* @@ -1578,14 +1586,6 @@ TclMakeEnsemble( } } Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); - - /* - * Switch on compilation always for core ensembles now that we can do - * nice bytecode things with them. - */ - - Tcl_SetEnsembleFlags(interp, ensemble, - ensembleFlags | ENSEMBLE_COMPILE); } Tcl_DStringFree(&buf); -- cgit v0.12 From 906e3c456afb4ee425936e01ffb768ae30271da4 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 23:19:14 +0000 Subject: Revise the CompileWord() and PushVarNameWord() macros to make explicit the SetLineInformation() that's in each of them. --- generic/tclCompCmds.c | 9 +-------- generic/tclCompile.h | 16 ++++++---------- 2 files changed, 7 insertions(+), 18 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a56727d..0a1a739 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3164,10 +3164,7 @@ TclPushVarName( CompileEnv *envPtr, /* Holds resulting instructions. */ int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ int *localIndexPtr, /* Must not be NULL. */ - int *isScalarPtr, /* Must not be NULL. */ - int line, /* Line the token starts on. */ - int *clNext) /* Reference to offset of next hidden cont. - * line. */ + int *isScalarPtr) /* Must not be NULL. */ { register const char *p; const char *name, *elName; @@ -3347,8 +3344,6 @@ TclPushVarName( if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { if (elNameChars) { - envPtr->line = line; - envPtr->clNext = clNext; TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { @@ -3360,8 +3355,6 @@ TclPushVarName( * The var name isn't simple: compile and push it. */ - envPtr->line = line; - envPtr->clNext = clNext; CompileTokens(envPtr, varTokenPtr, interp); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..a4ebd96 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1074,7 +1074,7 @@ MODULE_SCOPE void TclPrintSource(FILE *outFile, MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, - int *isScalarPtr, int line, int *clNext); + int *isScalarPtr); MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, char *bytes, int length, int flags); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -1515,13 +1515,10 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define CompileWord(envPtr, tokenPtr, interp, word) \ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ + PushLiteral((envPtr), (tokenPtr)[1].start, (tokenPtr)[1].size); \ } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ + SetLineInformation((word)); \ + CompileTokens((envPtr), (tokenPtr), (interp)); \ } /* @@ -1542,9 +1539,8 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] #define PushVarNameWord(i,v,e,f,l,sc,word) \ - TclPushVarName(i,v,e,f,l,sc, \ - mapPtr->loc[eclIndex].line[(word)], \ - mapPtr->loc[eclIndex].next[(word)]) + SetLineInformation(word); \ + TclPushVarName(i,v,e,f,l,sc) /* * Often want to issue one of two versions of an instruction based on whether -- cgit v0.12 From 979b26b406c0679a35edba070797e94d3ecb656a Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Jul 2013 16:25:51 +0000 Subject: Tests demonstrating the need for the last two SetLineInformation() calls. --- tests/info.test | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/tests/info.test b/tests/info.test index afdaaee..3057dd2 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2371,6 +2371,31 @@ test info-33.33 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append x {*}{ + } [return [info frame 0]] +} +test info-33.34 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append {*}{ + } x([return [info frame 0]]) {*}{ + } a +} +test info-33.35 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From 5e4c2308ce99d3d1349d0defd0585b05cd11e3fe Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Jul 2013 18:44:15 +0000 Subject: Global replace: CompileBody() -> BODY(). --- generic/tclCompCmds.c | 25 +++++++++---------------- generic/tclCompCmdsGR.c | 6 ++---- generic/tclCompCmdsSZ.c | 4 +--- generic/tclCompile.h | 14 +++++++------- 4 files changed, 19 insertions(+), 30 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0a1a739..561d816 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,12 +610,12 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - SetLineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, cmdTokenPtr, interp); + BODY(cmdTokenPtr, 1); } else { + SetLineInformation(1); CompileTokens(envPtr, cmdTokenPtr, interp); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -1467,8 +1467,7 @@ CompileDictEachCmd( * Compile the loop body itself. It should be stack-neutral. */ - SetLineInformation(3); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 3); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); @@ -1651,8 +1650,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords - 1); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -1992,8 +1990,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords-1); - CompileBody(envPtr, tokenPtr, interp); + BODY(tokenPtr, parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -2268,8 +2265,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - SetLineInformation(1); - CompileBody(envPtr, startTokenPtr, interp); + BODY(startTokenPtr, 1); TclEmitOpcode(INST_POP, envPtr); /* @@ -2292,8 +2288,7 @@ TclCompileForCmd( bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - SetLineInformation(4); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 4); ExceptionRangeEnds(envPtr, bodyRange); TclEmitOpcode(INST_POP, envPtr); @@ -2306,8 +2301,7 @@ TclCompileForCmd( nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - SetLineInformation(3); - CompileBody(envPtr, nextTokenPtr, interp); + BODY(nextTokenPtr, 3); ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, envPtr); @@ -2682,9 +2676,8 @@ CompileEachloopCmd( * Inline compile the loop body. */ - SetLineInformation(numWords - 1); ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, numWords - 1); ExceptionRangeEnds(envPtr, range); if (collect == TCL_EACH_COLLECT) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f7c15e6..0572cd3 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -264,8 +264,7 @@ TclCompileIfCmd( */ if (compileScripts) { - SetLineInformation(wordIdx); - CompileBody(envPtr, tokenPtr, interp); + BODY(tokenPtr, wordIdx); } if (realCond) { @@ -345,8 +344,7 @@ TclCompileIfCmd( * Compile the else command body. */ - SetLineInformation(wordIdx); - CompileBody(envPtr, tokenPtr, interp); + BODY(tokenPtr, wordIdx); } /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0497e8a..19e636d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -85,8 +85,6 @@ const AuxDataType tclJumptableInfoType = { TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) -#define BODY(token,index) \ - SetLineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ PushStringLiteral(envPtr, str) #define JUMP4(name,var) \ @@ -1499,7 +1497,7 @@ IssueSwitchChainedTests( } /* - * Now do the actual compilation. Note that we do not use CompileBody + * Now do the actual compilation. Note that we do not use BODY() * because we may have synthesized the tokens in a non-standard * pattern. */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a4ebd96..cf8475d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1407,16 +1407,16 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) /* - * Convenience macro for use when compiling bodies of commands. The ANSI C - * "prototype" for this macro is: + * Convenience macros for use when compiling bodies of commands. The ANSI C + * "prototype" for these macros are: * - * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp); + * static void BODY(Tcl_Token *tokenPtr, int word); */ -#define CompileBody(envPtr, tokenPtr, interp) \ - TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)) +#define BODY(tokenPtr, word) \ + SetLineInformation((word)); \ + TclCompileCmdWord(interp, (tokenPtr)+1, (tokenPtr)->numComponents, \ + envPtr) /* * Convenience macro for use when compiling tokens to be pushed. The ANSI C -- cgit v0.12 From a398b126a43e46efa6d6044b0bcf57a4b9385c4e Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Jul 2013 17:07:51 +0000 Subject: Prefer CompileWord() over CompileTokens() when possible. --- generic/tclCompCmds.c | 3 +-- generic/tclCompCmdsGR.c | 3 +-- generic/tclCompCmdsSZ.c | 3 +-- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 561d816..37ce335 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2638,8 +2638,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - SetLineInformation(i); - CompileTokens(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp, i); tempVar = (firstValueTemp + loopIndex); Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); TclEmitOpcode( INST_POP, envPtr); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 0572cd3..2c71dc5 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -699,8 +699,7 @@ TclCompileInfoLevelCmd( * list of arguments. */ - SetLineInformation(1); - CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); + CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1); TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } return TCL_OK; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 19e636d..3a91c83 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1282,8 +1282,7 @@ TclCompileSwitchCmd( */ /* Both methods push the value to match against onto the stack. */ - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); + CompileWord(envPtr, valueTokenPtr, interp, valueIndex); if (mode == Switch_Exact) { IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken, -- cgit v0.12 From 654dc20b4af9b37825f7faffaa0e714dad02ce92 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Jul 2013 19:09:59 +0000 Subject: Possible improvement in light of [86ceb4e2b6]. --- library/tm.tcl | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/library/tm.tcl b/library/tm.tcl index d2af4f5..955e84d 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,6 +238,15 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } + if {[string length [package ifneeded $pkgname $pkgversion]]} { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + continue + } + # We have found a candidate, generate a "provide script" # for it, and remember it. Note that we are using ::list # to do this; locally [list] means something else without -- cgit v0.12 From 59d8c6ba4b9cc7f77258e0cdae09b6d786f19fc4 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Jul 2013 20:16:11 +0000 Subject: Build CompileBasicNArgCommand on top of TclCompileInvocation. --- generic/tclBasic.c | 22 ++++++++++++++++++---- generic/tclCompile.c | 6 +++--- generic/tclCompile.h | 3 +++ generic/tclEnsemble.c | 10 ++++++++++ 4 files changed, 34 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b2a505a..963b53a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5633,6 +5633,24 @@ TclArgumentBCEnter( CFWordBC *lastPtr = NULL; /* + * ePtr->nline is the number of words originally parsed. + * + * objc is the number of elements getting invoked. + * + * If they are not the same, we arrived here by compiling an + * ensemble dispatch. Ensemble subcommands that lead to script + * evaluation are not supposed to get compiled, because a command + * such as [info level] in the script can expose some of the dispatch + * shenanigans. This means that we don't have to tend to the + * housekeeping, and can escape now. + */ + + if (ePtr->nline != objc) { + return; + } + + /* + * Having disposed of the ensemble cases, we can state... * A few truths ... * (1) ePtr->nline == objc * (2) (ePtr->line[word] < 0) => !literal, for all words @@ -5642,10 +5660,6 @@ TclArgumentBCEnter( * have to save them at compile time. */ - if (ePtr->nline != objc) { - Tcl_Panic ("TIP 280 data structure inconsistency"); - } - for (word = 1; word < objc; word++) { if (ePtr->line[word] >= 0) { int isnew; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5f4acff..a2c7131 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1777,8 +1777,8 @@ CompileCmdLiteral( TclEmitPush(cmdLitIdx, envPtr); } -static void -CompileInvocation( +void +TclCompileInvocation( Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, @@ -2095,7 +2095,7 @@ CompileCommandTokens( CompileExpanded(interp, parsePtr->tokenPtr, cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } else { - CompileInvocation(interp, parsePtr->tokenPtr, + TclCompileInvocation(interp, parsePtr->tokenPtr, cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 0bcd84e..b94bd93 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1003,6 +1003,9 @@ MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr); +MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, + Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, + CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, const char *script, int numBytes, CompileEnv *envPtr); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 680ab45d..9b6ca92 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3229,6 +3229,15 @@ CompileBasicNArgCommand( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { +#if 1 + Tcl_Obj *objPtr = Tcl_NewObj(); + + Tcl_IncrRefCount(objPtr); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, + parsePtr->numWords, envPtr); + Tcl_DecrRefCount(objPtr); +#else Tcl_Token *tokenPtr; Tcl_Obj *objPtr; char *bytes; @@ -3272,6 +3281,7 @@ CompileBasicNArgCommand( } else { TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); } +#endif return TCL_OK; } -- cgit v0.12 From 2d98ee0f477ef33bb0a8473efbd44ef203463c32 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 14:07:41 +0000 Subject: Eliminate the litInfo table and all the code tending to its care and feeding. The pc -> command index mapping function it provided can be achieved using other data already in the ByteCode struct. --- generic/tclBasic.c | 134 +++++++++++++++++++++++++-------------------------- generic/tclCompile.c | 43 ----------------- generic/tclCompile.h | 8 --- generic/tclExecute.c | 44 ++++++++++++----- generic/tclInt.h | 2 +- 5 files changed, 97 insertions(+), 134 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 963b53a..bd4f157 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1609,8 +1609,6 @@ DeleteInterpProc( ckfree(eclPtr->loc); } - Tcl_DeleteHashTable(&eclPtr->litInfo); - ckfree(eclPtr); Tcl_DeleteHashEntry(hPtr); } @@ -5614,90 +5612,88 @@ TclArgumentBCEnter( int objc, void *codePtr, CmdFrame *cfPtr, + int cmd, int pc) { + ExtCmdLoc *eclPtr; + int word; + ECL *ePtr; + CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - ExtCmdLoc *eclPtr; if (!hePtr) { return; } eclPtr = Tcl_GetHashValue(hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); - if (hePtr) { - int word; - int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); - ECL *ePtr = &eclPtr->loc[cmd]; - CFWordBC *lastPtr = NULL; + ePtr = &eclPtr->loc[cmd]; - /* - * ePtr->nline is the number of words originally parsed. - * - * objc is the number of elements getting invoked. - * - * If they are not the same, we arrived here by compiling an - * ensemble dispatch. Ensemble subcommands that lead to script - * evaluation are not supposed to get compiled, because a command - * such as [info level] in the script can expose some of the dispatch - * shenanigans. This means that we don't have to tend to the - * housekeeping, and can escape now. - */ + /* + * ePtr->nline is the number of words originally parsed. + * + * objc is the number of elements getting invoked. + * + * If they are not the same, we arrived here by compiling an + * ensemble dispatch. Ensemble subcommands that lead to script + * evaluation are not supposed to get compiled, because a command + * such as [info level] in the script can expose some of the dispatch + * shenanigans. This means that we don't have to tend to the + * housekeeping, and can escape now. + */ - if (ePtr->nline != objc) { - return; - } + if (ePtr->nline != objc) { + return; + } - /* - * Having disposed of the ensemble cases, we can state... - * A few truths ... - * (1) ePtr->nline == objc - * (2) (ePtr->line[word] < 0) => !literal, for all words - * (3) (word == 0) => !literal - * - * Item (2) is why we can use objv to get the literals, and do not - * have to save them at compile time. - */ + /* + * Having disposed of the ensemble cases, we can state... + * A few truths ... + * (1) ePtr->nline == objc + * (2) (ePtr->line[word] < 0) => !literal, for all words + * (3) (word == 0) => !literal + * + * Item (2) is why we can use objv to get the literals, and do not + * have to save them at compile time. + */ - for (word = 1; word < objc; word++) { - if (ePtr->line[word] >= 0) { - int isnew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isnew); - CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); - - cfwPtr->framePtr = cfPtr; - cfwPtr->obj = objv[word]; - cfwPtr->pc = pc; - cfwPtr->word = word; - cfwPtr->nextPtr = lastPtr; - lastPtr = cfwPtr; - - if (isnew) { - /* - * The word is not on the stack yet, remember the current - * location and initialize references. - */ - - cfwPtr->prevPtr = NULL; - } else { - /* - * The object is already on the stack, however it may have - * a different location now (literal sharing may map - * multiple location to a single Tcl_Obj*. Save the old - * information in the new structure. - */ - - cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); - } + for (word = 1; word < objc; word++) { + if (ePtr->line[word] >= 0) { + int isnew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, + objv[word], &isnew); + CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); - Tcl_SetHashValue(hPtr, cfwPtr); + cfwPtr->framePtr = cfPtr; + cfwPtr->obj = objv[word]; + cfwPtr->pc = pc; + cfwPtr->word = word; + cfwPtr->nextPtr = lastPtr; + lastPtr = cfwPtr; + + if (isnew) { + /* + * The word is not on the stack yet, remember the current + * location and initialize references. + */ + + cfwPtr->prevPtr = NULL; + } else { + /* + * The object is already on the stack, however it may have + * a different location now (literal sharing may map + * multiple location to a single Tcl_Obj*. Save the old + * information in the new structure. + */ + + cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); } - } /* for */ - cfPtr->litarg = lastPtr; - } /* if */ + Tcl_SetHashValue(hPtr, cfwPtr); + } + } /* for */ + + cfPtr->litarg = lastPtr; } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a2c7131..7e0be76 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1296,8 +1296,6 @@ ReleaseCmdWordData( ckfree((char *) eclPtr->loc); } - Tcl_DeleteHashTable (&eclPtr->litInfo); - ckfree((char *) eclPtr); } @@ -1382,7 +1380,6 @@ TclInitCompileEnv( envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; envPtr->extCmdMapPtr->path = NULL; - Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS); if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) { /* @@ -1814,12 +1811,6 @@ TclCompileInvocation( TclEmitPush(objIdx, envPtr); } - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ - - mapPtr->loc[eclIndex].invokePc = envPtr->codeNext - envPtr->codeStart; - if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); } else { @@ -2001,7 +1992,6 @@ CompileCmdCompileProc( mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; - mapPtr->loc[mapPtr->nuloc].invokePc = -1; } SetLineInformation(0); @@ -3325,17 +3315,6 @@ TclInitByteCodeObj( * byte code object (internal rep), for use with the bc compiler. */ - for (i = 0; i < envPtr->extCmdMapPtr->nuloc; i++) { - int isnew, pc = envPtr->extCmdMapPtr->loc[i].invokePc; - - if (pc < 0) { - continue; - } - - Tcl_SetHashValue(Tcl_CreateHashEntry(&envPtr->extCmdMapPtr->litInfo, - INT2PTR(pc), &isnew), INT2PTR(i)); - } - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr, &isNew), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; @@ -3706,7 +3685,6 @@ EnterCmdWordData( ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; - ePtr->invokePc = -1; ePtr->line = ckalloc(numWords * sizeof(int)); ePtr->next = ckalloc(numWords * sizeof(int *)); ePtr->nline = numWords; @@ -4477,27 +4455,6 @@ TclFixupForwardJump( } } - /* - * TIP #280: Adjust the mapping from PC values to the per-command - * information about arguments and their line numbers. - * - * Note: We cannot simply remove an out-of-date entry and then reinsert - * with the proper PC, because then we might overwrite another entry which - * was at that location. Therefore we pull (copy + delete) all effected - * entries (beyond the fixed PC) into an array, update them there, and at - * last reinsert them all. - */ - - { - ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; - for (k = eclPtr->nuloc - 1; k >= 0; k--) { - if (eclPtr->loc[k].invokePc < (jumpFixupPtr->codeOffset + 2)) { - continue; - } - eclPtr->loc[k].invokePc += 3; - } - } - return 1; /* the jump was grown */ } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b94bd93..f70f8f7 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -175,7 +175,6 @@ typedef struct CmdLocation { typedef struct ECL { int srcOffset; /* Command location to find the entry. */ - int invokePc; int nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ @@ -194,13 +193,6 @@ typedef struct ExtCmdLoc { ECL *loc; /* Command word locations (lines). */ int nloc; /* Number of allocated entries in 'loc'. */ int nuloc; /* Number of used entries in 'loc'. */ - Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the - * information accessible per command and - * argument, not per whole bytecode. Value is - * index of command in 'loc', giving us the - * literals to associate with line information - * as command argument, see - * TclArgumentBCEnter() */ } ExtCmdLoc; /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 37bf072..f8ed667 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -721,7 +721,7 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr, - const unsigned char **pcBeg); + const unsigned char **pcBeg, int *cmdIdxPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, @@ -2431,8 +2431,11 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } pc++; @@ -2885,8 +2888,11 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } DECACHE_STACK_INFO(); @@ -3031,8 +3037,11 @@ TEBCresume( 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); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = opnd; @@ -6967,7 +6976,7 @@ TEBCresume( if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { const unsigned char *pcBeg; - bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); + bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL); DECACHE_STACK_INFO(); TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr); @@ -7149,7 +7158,7 @@ TEBCresume( } codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); @@ -8642,7 +8651,7 @@ ValidatePcAndStackTop( if (checkStack && ((stackTop < 0) || (stackTop > stackUpperBound))) { int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", stackTop, relativePc, stackUpperBound); @@ -8756,7 +8765,7 @@ TclGetSrcInfoForCmd( ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr, NULL); + codePtr, lenPtr, NULL, NULL); } void @@ -8768,7 +8777,7 @@ TclGetSrcInfoForPc( if (cfPtr->cmd.str.cmd == NULL) { cfPtr->cmd.str.cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->cmd.str.len, NULL); + &cfPtr->cmd.str.len, NULL, NULL); } if (cfPtr->cmd.str.cmd != NULL) { @@ -8828,9 +8837,12 @@ GetSrcInfoForPc( int *lengthPtr, /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ - const unsigned char **pcBeg)/* If non-NULL, the bytecode location + const unsigned char **pcBeg,/* If non-NULL, the bytecode location * where the current instruction starts. * If NULL; no pointer is stored. */ + int *cmdIdxPtr) /* If non-NULL, the location where the index + * of the command containing the pc should + * be stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -8840,6 +8852,7 @@ GetSrcInfoForPc( int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + int bestCmdIdx = -1; if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { if (pcBeg != NULL) *pcBeg = NULL; @@ -8907,6 +8920,7 @@ GetSrcInfoForPc( bestDist = dist; bestSrcOffset = srcOffset; bestSrcLength = srcLen; + bestCmdIdx = i; } } } @@ -8936,6 +8950,10 @@ GetSrcInfoForPc( *lengthPtr = bestSrcLength; } + if (cmdIdxPtr != NULL) { + *cmdIdxPtr = bestCmdIdx; + } + return (codePtr->source + bestSrcOffset); } diff --git a/generic/tclInt.h b/generic/tclInt.h index b940225..da09366 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2828,7 +2828,7 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int pc); + void *codePtr, CmdFrame *cfPtr, int cmd, int pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, -- cgit v0.12 From e783ef57ec6e0ab2d08f1524e86cbc849e36f763 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 14:52:33 +0000 Subject: Simplify arguments to TclContinuationsEnterDerived(). --- generic/tclCompile.c | 6 ++---- generic/tclEnsemble.c | 14 ++++++++------ 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7e0be76..bc7501a 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1805,8 +1805,7 @@ TclCompileInvocation( tokenPtr[1].start, tokenPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[wordIdx]); + tokenPtr[1].start - envPtr->source, envPtr->clNext); } TclEmitPush(objIdx, envPtr); } @@ -1855,8 +1854,7 @@ CompileExpanded( tokenPtr[1].start, tokenPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[wordIdx]); + tokenPtr[1].start - envPtr->source, envPtr->clNext); } TclEmitPush(objIdx, envPtr); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 9b6ca92..864283b 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3163,12 +3163,16 @@ CompileToInvokedCommand( */ Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); - for (i=0,tokPtr=parsePtr->tokenPtr ; inumWords ; i++) { + for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; + i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); - } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* TODO: Check about registering Cmd Literals here */ + continue; + } + + SetLineInformation(i); + if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { int literal = TclRegisterNewLiteral(envPtr, tokPtr[1].start, tokPtr[1].size); @@ -3176,14 +3180,12 @@ CompileToInvokedCommand( TclContinuationsEnterDerived( TclFetchLiteral(envPtr, literal), tokPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[i]); + envPtr->clNext); } TclEmitPush(literal, envPtr); } else { - SetLineInformation(i); CompileTokens(envPtr, tokPtr, interp); } - tokPtr = TokenAfter(tokPtr); } /* -- cgit v0.12 From 01f1692c1f639eeb817ce6c51928195620872173 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 17:21:12 +0000 Subject: Simplify the ensemble subcommand compile. There's no need to be crafting synthetic Tcl_Parse and copying tokens. Some pointer shifts will do. --- generic/tclCompile.c | 1 - generic/tclEnsemble.c | 70 +++++++++++---------------------------------------- 2 files changed, 15 insertions(+), 56 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index bc7501a..d82d728 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1992,7 +1992,6 @@ CompileCmdCompileProc( mapPtr->loc[mapPtr->nuloc].line = NULL; } - SetLineInformation(0); return TCL_ERROR; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 864283b..e4f96c0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3029,12 +3029,6 @@ TclCompileEnsemble( return ourResult; } -/* - * How to compile a subcommand using its own command compiler. To do that, we - * have to perform some trickery to rewrite the arguments, as compilers *must* - * have parse tokens that refer to addresses in the original script. - */ - static int CompileToCompiledCommand( Tcl_Interp *interp, @@ -3043,10 +3037,8 @@ CompileToCompiledCommand( Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Parse synthetic; - Tcl_Token *tokenPtr; int result, i; - int savedNumCmds = envPtr->numCommands; + Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; DefineLineInformation; @@ -3055,47 +3047,17 @@ CompileToCompiledCommand( return TCL_ERROR; } - TclParseInit(interp, NULL, 0, &synthetic); - synthetic.numWords = parsePtr->numWords - depth + 1; - TclGrowParseTokenArray(&synthetic, 2); - synthetic.numTokens = 2; - - /* - * Now we have the space to work in, install something rewritten. The - * first word will "officially" be the bytes of the structured ensemble - * name. That's technically wrong, but nobody will care; we just need - * *something* here... - */ - - synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD; - synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[0].numComponents = 1; - synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT; - synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[1].numComponents = 0; - for (i=0,tokenPtr=parsePtr->tokenPtr ; istart - synthetic.tokenPtr[0].start) - + tokenPtr->size; - - synthetic.tokenPtr[0].size = sclen; - synthetic.tokenPtr[1].size = sclen; - tokenPtr = TokenAfter(tokenPtr); - } - /* - * Copy over the real argument tokens. + * Advance parsePtr->tokenPtr so that it points at the last subcommand. + * This will be wrong, but it will not matter, and it will put the + * tokens for the arguments in the right place without the needed to + * allocate a synthetic Tcl_Parse struct, or copy tokens around. */ - for (i=1; inumComponents + 1; - TclGrowParseTokenArray(&synthetic, toCopy); - memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, - sizeof(Tcl_Token) * toCopy); - synthetic.numTokens += toCopy; - tokenPtr = TokenAfter(tokenPtr); + for (i = 0; i < depth - 1; i++) { + parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr); } + parsePtr->numWords -= (depth - 1); /* * Shift the line information arrays to account for different word @@ -3109,7 +3071,7 @@ CompileToCompiledCommand( * Hand off compilation to the subcommand compiler. At last! */ - result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr); /* * Undo the shift. @@ -3118,22 +3080,20 @@ CompileToCompiledCommand( mapPtr->loc[eclIndex].line -= (depth - 1); mapPtr->loc[eclIndex].next -= (depth - 1); + parsePtr->numWords += (depth - 1); + parsePtr->tokenPtr = saveTokenPtr; + /* - * If our target fails to compile, revert the number of commands and the - * pointer to the place to issue the next instruction. [Bug 3600328] + * If our target failed to compile, revert any data from failed partial + * compiles. Note that envPtr->numCommands need not be checked because + * we avoid compiling subcommands that recursively call TclCompileScript(). */ if (result != TCL_OK) { - envPtr->numCommands = savedNumCmds; envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; } - /* - * Clean up if necessary. - */ - - Tcl_FreeParse(&synthetic); return result; } -- cgit v0.12 From 945323c68b1aaa265a1467ae1d1101a618e871a9 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 20:48:37 +0000 Subject: Streamline the housekeeping on the operands of INST_START_CMD. For example, do only incr on success, not incr on attempt + decr on error. --- generic/tclCompile.c | 81 +++++++++++++++++++++------------------------------- 1 file changed, 32 insertions(+), 49 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d82d728..6ac5fb9 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1885,47 +1885,41 @@ CompileCmdCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, - int startCodeOffset, CompileEnv *envPtr) { int savedNumCmds = envPtr->numCommands; int startStackDepth = envPtr->currStackDepth; - int update = 0; + int startCodeOffset = envPtr->codeNext - envPtr->codeStart; + int incrOffset = -1; DefineLineInformation; /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD - * in special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] + * Emit of the INST_START_CMD instruction is controlled by + * the value of envPtr->atCmdStart: * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. + * atCmdStart == 2 : We are not using the INST_START_CMD instruction. + * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. + * : We do not need to emit another. Instead we + * : increment the number of cmds started at it (except + * : for the special case at the start of a script.) + * atCmdStart == 0 : The last instruction was something else. We need + * : to emit INST_START_CMD here. */ - if (envPtr->atCmdStart == 1) { - if (startCodeOffset) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) - } - } else if (envPtr->atCmdStart == 0) { + switch (envPtr->atCmdStart) { + case 0: TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; + incrOffset = envPtr->codeNext - envPtr->codeStart; + TclEmitInt4(0, envPtr); + break; + case 1: + if (envPtr->codeNext > envPtr->codeStart) { + incrOffset = envPtr->codeNext - 4 - envPtr->codeStart; + } + break; + case 2: + /* Nothing to do */ + ; } if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { @@ -1947,30 +1941,20 @@ CompileCmdCompileProc( parsePtr->tokenPtr->start, diff); } #endif - if (update) { + if (incrOffset >= 0) { /* - * Fix the bytecode length. + * We successfully compiled a command. Increment the number + * of commands that start at the currently active INST_START_CMD. */ + unsigned char *incrPtr = envPtr->codeStart + incrOffset; + unsigned char *startPtr = incrPtr - 5; - unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; - unsigned fixLen = envPtr->codeNext - fixPtr + 1; - - TclStoreInt4AtPtr(fixLen, fixPtr); + TclIncrUInt4AtPtr(incrPtr, 1); + TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); } return TCL_OK; } - if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); - } - /* * Restore numCommands, codeNext, and currStackDepth to their * correct values, removing any commands compiled before the @@ -2069,8 +2053,7 @@ CompileCommandTokens( /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ if (cmdPtr) { - code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, - startCodeOffset, envPtr); + code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr); } if (code == TCL_ERROR) { -- cgit v0.12 From 6d2beac7e80048bcc4d4d46c68ec4f55d90986b3 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Jul 2013 13:57:23 +0000 Subject: Factor out the call to a compileProc into one place used by both ensemble subcommand compiles and toplevel command compiles in TclCompileScript. --- generic/tclCompile.c | 48 ++++++++++++++---------------------------------- generic/tclCompile.h | 3 +++ generic/tclEnsemble.c | 28 +++++++++++++++++++++------- 3 files changed, 38 insertions(+), 41 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6ac5fb9..763e8f1 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1887,10 +1887,7 @@ CompileCmdCompileProc( Command *cmdPtr, CompileEnv *envPtr) { - int savedNumCmds = envPtr->numCommands; - int startStackDepth = envPtr->currStackDepth; - int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - int incrOffset = -1; + int unwind = 0, incrOffset = -1; DefineLineInformation; /* @@ -1908,6 +1905,7 @@ CompileCmdCompileProc( switch (envPtr->atCmdStart) { case 0: + unwind = tclInstructionTable[INST_START_CMD].numBytes; TclEmitInstInt4(INST_START_CMD, 0, envPtr); incrOffset = envPtr->codeNext - envPtr->codeStart; TclEmitInt4(0, envPtr); @@ -1922,25 +1920,7 @@ CompileCmdCompileProc( ; } - if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { - -#ifdef TCL_COMPILE_DEBUG - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ - - int diff = envPtr->currStackDepth - startStackDepth; - - if (diff != 1) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { if (incrOffset >= 0) { /* * We successfully compiled a command. Increment the number @@ -1950,21 +1930,15 @@ CompileCmdCompileProc( unsigned char *startPtr = incrPtr - 5; TclIncrUInt4AtPtr(incrPtr, 1); - TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); + if (unwind) { + /* We started the INST_START_CMD. Record the code length. */ + TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); + } } return TCL_OK; } - /* - * Restore numCommands, codeNext, and currStackDepth to their - * correct values, removing any commands compiled before the - * failure to produce bytecode got reported. - * [Bugs 705406, 735055, 3614102] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + startCodeOffset; - envPtr->currStackDepth = startStackDepth; + envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ /* * Throw out any line information generated by the failed @@ -1976,6 +1950,12 @@ CompileCmdCompileProc( mapPtr->loc[mapPtr->nuloc].line = NULL; } + /* + * Reset the index of next command. + * Toss out any from failed nested partial compiles. + */ + envPtr->numCommands = mapPtr->nuloc; + return TCL_ERROR; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index f70f8f7..56315db 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -984,6 +984,9 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, *---------------------------------------------------------------- */ +MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, + Tcl_Parse *parsePtr, int depth, Command *cmdPtr, + CompileEnv *envPtr); MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index e4f96c0..bab63c9 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -35,9 +35,6 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); -static int CompileToCompiledCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int depth, Command *cmdPtr, - CompileEnv *envPtr); static void CompileToInvokedCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Obj *replacements, Command *cmdPtr, CompileEnv *envPtr); @@ -2994,8 +2991,8 @@ TclCompileEnsemble( */ invokeAnyway = 1; - if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr, - envPtr) == TCL_OK) { + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr, + envPtr)) { ourResult = TCL_OK; goto cleanup; } @@ -3029,8 +3026,8 @@ TclCompileEnsemble( return ourResult; } -static int -CompileToCompiledCommand( +int +TclAttemptCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, @@ -3092,6 +3089,23 @@ CompileToCompiledCommand( if (result != TCL_OK) { envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; +#ifdef TCL_COMPILE_DEBUG + } else { + /* + * Confirm that the command compiler generated a single value on + * the stack as its result. This is only done in debugging mode, + * as it *should* be correct and normal users have no reasonable + * way to fix it anyway. + */ + + int diff = envPtr->currStackDepth - savedStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif } return result; -- cgit v0.12 From 6b9dcf87ecc79d795e79e3d6d8e03b894f36a6cc Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 17 Jul 2013 16:02:36 +0000 Subject: Start notifier thread again if we were forked, to solve Rivet bug 55153 - RFE [a0bc856dcd] --- ChangeLog | 6 ++++++ unix/tclUnixNotfy.c | 21 +++++++++++++++++++++ 2 files changed, 27 insertions(+) diff --git a/ChangeLog b/ChangeLog index d7ada95..bdbbd4a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2013-07-17 Harald Oehlmann + + * tclUnixNotify.c Tcl_InitNotifier: RFE [a0bc856dcd] + Start notifier thread again if we were forked, to solve Rivet bug + 55153. + 2013-07-05 Kevin B. Kenny * library/tzdata/Africa/Casablanca: diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index aacc8d2d..2ad1932 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -120,6 +120,15 @@ static Tcl_ThreadDataKey dataKey; static int notifierCount = 0; /* + * The following static stores the process ID of the initialized notifier + * thread. If it changes, we have passed a fork and we should start a new + * notifier thread. + * + * You must hold the notifierMutex lock before accessing this variable. + */ +static pid_t processIDInitialized = 0; + +/* * The following variable points to the head of a doubly-linked list of * ThreadSpecificData structures for all threads that are currently waiting on * an event. @@ -275,11 +284,23 @@ Tcl_InitNotifier(void) */ Tcl_MutexLock(¬ifierMutex); + /* + * Check if my process id changed, e.g. I was forked + * In this case, restart the notifier thread and close the + * pipe to the original notifier thread + */ + if (notifierCount > 0 && processIDInitialized != getpid()) { + notifierCount = 0; + processIDInitialized = 0; + close(triggerPipe); + triggerPipe = -1; + } if (notifierCount == 0) { if (TclpThreadCreate(¬ifierThread, NotifierThreadProc, NULL, TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread"); } + processIDInitialized = getpid(); } notifierCount++; -- cgit v0.12 From 517197f8571ca5ff1c51b2cadc771505922d9137 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 18 Jul 2013 15:05:18 +0000 Subject: [Bug 1c17fbba5d] Fix -errorinfo from syntax errors so that the error is not obscured. Instead highlight it by making it the last character quoted. --- generic/tclAssembly.c | 15 ++++++++------- generic/tclBasic.c | 5 ++++- generic/tclCompile.c | 5 +---- tests/assemble.test | 3 +-- tests/misc.test | 7 +------ 5 files changed, 15 insertions(+), 20 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 62641e6..416ee10 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -985,8 +985,6 @@ TclAssembleCode( const char* instPtr = codePtr; /* Where to start looking for a line of code */ - int instLen; /* Length in bytes of the current line of - * code */ const char* nextPtr; /* Pointer to the end of the line of code */ int bytesLeft = codeLen; /* Number of bytes of source code remaining to * be parsed */ @@ -1000,10 +998,6 @@ TclAssembleCode( */ status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); - instLen = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + instLen - 1) { - --instLen; - } /* * Report errors in the parse. @@ -1012,7 +1006,7 @@ TclAssembleCode( if (status != TCL_OK) { if (flags & TCL_EVAL_DIRECT) { Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, - instLen); + parsePtr->term + 1 - parsePtr->commandStart); } FreeAssemblyEnv(assemEnvPtr); return TCL_ERROR; @@ -1032,6 +1026,13 @@ TclAssembleCode( */ if (parsePtr->numWords > 0) { + int instLen = parsePtr->commandSize; + /* Length in bytes of the current command */ + + if (parsePtr->term == parsePtr->commandStart + instLen - 1) { + --instLen; + } + /* * If tracing, show each line assembled as it happens. */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b2a505a..1d35034 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5084,7 +5084,9 @@ TclEvalEx( do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { code = TCL_ERROR; - goto error; + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + parsePtr->term + 1 - parsePtr->commandStart); + goto posterror; } /* @@ -5340,6 +5342,7 @@ TclEvalEx( Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } + posterror: iPtr->flags &= ~ERR_ALREADY_LOGGED; /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 633966e..6a2a318 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1790,10 +1790,7 @@ TclCompileScript( */ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - /* Drop the command terminator (";","]") if appropriate */ - (parsePtr->term == - parsePtr->commandStart + parsePtr->commandSize - 1)? - parsePtr->commandSize - 1 : parsePtr->commandSize); + parsePtr->term + 1 - parsePtr->commandStart); TclCompileSyntaxError(interp, envPtr); break; } diff --git a/tests/assemble.test b/tests/assemble.test index 7d4e5d1..b0487e6 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} { -match glob -result {1 {extra characters after close-brace} {extra characters after close-brace while executing -"{}extra - " +"{}e" ("assemble" body, line 2)*}} } test assemble-4.2 {null command} { diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..d4ece74 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} { missing close-brace for variable name missing close-brace for variable name while executing -"set tst $a([winfo name $\{zz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." +"set tst $a([winfo name $\{" (procedure "tstProc" line 4) invoked from within "tstProc"}] -- cgit v0.12 From f06af4fe86a953a20b9ef90f5605331707370765 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 18 Jul 2013 18:25:24 +0000 Subject: [assemble] compile syntax error into bytecode reporting syntax error message. --- generic/tclAssembly.c | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 0722eb9..9b9b6f8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -930,7 +930,7 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ -#if 0 +#if 1 int numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; int depth = envPtr->currStackDepth; @@ -956,11 +956,7 @@ TclCompileAssembleCmd( if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, TCL_EVAL_DIRECT)) { - /* - * TODO: Finish working out how to capture syntax errors captured - * during compile and make them bytecode reporting the error. - */ -#if 0 +#if 1 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s\" body, line %d)", parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, @@ -1136,7 +1132,7 @@ NewAssemblyEnv( assemEnvPtr->envPtr = envPtr; assemEnvPtr->parsePtr = parsePtr; - assemEnvPtr->cmdLine = envPtr->line; + assemEnvPtr->cmdLine = 1; assemEnvPtr->clNext = envPtr->clNext; /* -- cgit v0.12 From ec06295d4ed7d6f865b8d73925bfb24d8f478f45 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 22 Jul 2013 08:45:37 +0000 Subject: Test file tests/unixForkEvent.test added --- tests/unixForkEvent.test | 50 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) create mode 100644 tests/unixForkEvent.test diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test new file mode 100644 index 0000000..fee45fd --- /dev/null +++ b/tests/unixForkEvent.test @@ -0,0 +1,50 @@ +# This file contains a collection of tests for the procedures in the file +# tclEvent.c, which includes the "update", and "vwait" Tcl +# commands. Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcltest 2 +namespace import -force ::tcltest::* + +testConstraint testfork [llength [info commands testfork]] +testConstraint threaded [expr { + ([info exist tcl_platform(threaded)] && $tcl_platform(threaded)) + && $tcl_platform(os) ne "Darwin" +}] + +# Test if the notifier thread is well initialized in a forked interpreter +# by Tcl_InitNotifier +test unixforkevent-1.1 {fork and test writeable event} \ + -constraints {threaded testfork} \ + -body { + set folder [makeDirectory unixtestfork] + set pid [testfork] + if {$pid == 0} { + # we are the forked process + set result initialized + set h [open [file join $folder test.txt] w] + fileevent $h writable\ + "set result writable;\ + after cancel [after 1000 {set result timeout}]" + vwait result + close $h + makeFile $result result.txt $folder + exit + } + # we are the original process + while {![file readable [file join $folder result.txt]]} {} + viewFile result.txt $folder + } \ + -result {writable} \ + -cleanup { + catch { removeFolder $folder } + } + +::tcltest::cleanupTests +return -- cgit v0.12 From 978b54229dc68812a5ccaa0050324d215db91520 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Jul 2013 10:10:00 +0000 Subject: Fix bug which hangs iocmd.tf-32.1 --- unix/tclUnixNotfy.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index 88e290e..6e8b5fa 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -291,8 +291,8 @@ Tcl_InitNotifier(void) if (TclpThreadCreate(¬ifierThread, NotifierThreadProc, NULL, TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread"); - processIDInitialized = getpid(); } + processIDInitialized = getpid(); } notifierCount++; -- cgit v0.12 From f9820a2863b758aa1d07274355cd62f9ecbddae1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Jul 2013 10:11:05 +0000 Subject: Test-case should pass on Darwin or with non-threaded build as well. --- tests/unixForkEvent.test | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test index fee45fd..a0c3f19 100644 --- a/tests/unixForkEvent.test +++ b/tests/unixForkEvent.test @@ -1,7 +1,6 @@ # This file contains a collection of tests for the procedures in the file -# tclEvent.c, which includes the "update", and "vwait" Tcl -# commands. Sourcing this file into Tcl runs the tests and generates -# output for errors. No output means no errors were found. +# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. @@ -13,15 +12,11 @@ package require tcltest 2 namespace import -force ::tcltest::* testConstraint testfork [llength [info commands testfork]] -testConstraint threaded [expr { - ([info exist tcl_platform(threaded)] && $tcl_platform(threaded)) - && $tcl_platform(os) ne "Darwin" -}] # Test if the notifier thread is well initialized in a forked interpreter # by Tcl_InitNotifier test unixforkevent-1.1 {fork and test writeable event} \ - -constraints {threaded testfork} \ + -constraints testfork \ -body { set folder [makeDirectory unixtestfork] set pid [testfork] -- cgit v0.12 From a038288139470e7a32c1e711fcfdbd64212e87e4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Jul 2013 10:57:44 +0000 Subject: Use pthread_atfork() when available. --- unix/configure | 209 +++++++++++++++++++++++++++------------------------- unix/configure.in | 7 +- unix/tclUnixNotfy.c | 90 +++++++++++++++++++++- 3 files changed, 202 insertions(+), 104 deletions(-) diff --git a/unix/configure b/unix/configure index 6faa7d8..ee194b7 100755 --- a/unix/configure +++ b/unix/configure @@ -16759,6 +16759,113 @@ done #-------------------------------------------------------------------- +# Check for support of pthread_atfork function +#-------------------------------------------------------------------- + + +for ac_func in pthread_atfork +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 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_exeext' + { (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 + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + +#-------------------------------------------------------------------- # Check for support of isnan() function or macro #-------------------------------------------------------------------- @@ -17439,108 +17546,6 @@ _ACEOF fi done - -for ac_func in pthread_atfork -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define $ac_func to an innocuous variant, in case declares $ac_func. - For example, HP-UX 11i declares gettimeofday. */ -#define $ac_func innocuous_$ac_func - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $ac_func - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 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_exeext' - { (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 - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - fi cat >>confdefs.h <<\_ACEOF diff --git a/unix/configure.in b/unix/configure.in index e22a7d3..f47b882 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -491,6 +491,12 @@ SC_ENABLE_LANGINFO AC_CHECK_FUNCS(chflags) #-------------------------------------------------------------------- +# Check for support of pthread_atfork function +#-------------------------------------------------------------------- + +AC_CHECK_FUNCS(pthread_atfork) + +#-------------------------------------------------------------------- # Check for support of isnan() function or macro #-------------------------------------------------------------------- @@ -513,7 +519,6 @@ if test "`uname -s`" = "Darwin" ; then if test $tcl_corefoundation = yes; then AC_CHECK_HEADERS(libkern/OSAtomic.h) AC_CHECK_FUNCS(OSSpinLockLock) - AC_CHECK_FUNCS(pthread_atfork) fi AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?]) AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8", diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index 6e8b5fa..f414c3f 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -202,7 +202,13 @@ static Tcl_ThreadId notifierThread; #ifdef TCL_THREADS static void NotifierThreadProc(ClientData clientData); -#endif +#ifdef HAVE_PTHREAD_ATFORK +static int atForkInit = 0; +static void AtForkPrepare(void); +static void AtForkParent(void); +static void AtForkChild(void); +#endif /* HAVE_PTHREAD_ATFORK */ +#endif /* TCL_THREADS */ static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); /* @@ -276,6 +282,21 @@ Tcl_InitNotifier(void) */ Tcl_MutexLock(¬ifierMutex); +#ifdef HAVE_PTHREAD_ATFORK + /* + * Install pthread_atfork handlers to reinitialize the notifier in the + * child of a fork. + */ + + if (!atForkInit) { + int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild); + + if (result) { + Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed"); + } + atForkInit = 1; + } +#endif /* * Check if my process id changed, e.g. I was forked * In this case, restart the notifier thread and close the @@ -1251,6 +1272,73 @@ NotifierThreadProc( TclpThreadExit (0); } + +#ifdef HAVE_PTHREAD_ATFORK +/* + *---------------------------------------------------------------------- + * + * AtForkPrepare -- + * + * Lock the notifier in preparation for a fork. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AtForkPrepare(void) +{ +} + +/* + *---------------------------------------------------------------------- + * + * AtForkParent -- + * + * Unlock the notifier in the parent after a fork. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AtForkParent(void) +{ +} + +/* + *---------------------------------------------------------------------- + * + * AtForkChild -- + * + * Unlock and reinstall the notifier in the child after a fork. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AtForkChild(void) +{ + Tcl_InitNotifier(); +} +#endif /* HAVE_PTHREAD_ATFORK */ + #endif /* TCL_THREADS */ #endif /* HAVE_COREFOUNDATION */ -- cgit v0.12 From 7a32d8f6e8b39e52c94b3a375a95bd3b6669c12e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Jul 2013 11:11:10 +0000 Subject: Tcl_InitNotifier() call in TestforkObjCmd() is only necessary when pthread_atfork() is not available. --- unix/tclUnixTest.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 39cddef..2fc1647 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -574,9 +574,12 @@ TestforkObjCmd( "Cannot fork", NULL); return TCL_ERROR; } +#ifndef HAVE_PTHREAD_ATFORK + /* Only needed when pthread_atfork is not present. */ if (pid==0) { Tcl_InitNotifier(); } +#endif Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); return TCL_OK; } -- cgit v0.12 From c81da08d4a5ddf07bf70bab9be966473b2520644 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Jul 2013 09:07:21 +0000 Subject: Add "testfork" test command. Not used in any test-case yet --- unix/configure | 204 ++++++++++++++++++++++++++--------------------------- unix/configure.in | 2 +- unix/tclUnixTest.c | 50 +++++++++++++ 3 files changed, 153 insertions(+), 103 deletions(-) diff --git a/unix/configure b/unix/configure index 6faa7d8..9fa5673 100755 --- a/unix/configure +++ b/unix/configure @@ -5303,6 +5303,108 @@ echo "${ECHO_T}no (default)" >&6 +for ac_func in pthread_atfork +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 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_exeext' + { (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 + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 #------------------------------------------------------------------------ @@ -17439,108 +17541,6 @@ _ACEOF fi done - -for ac_func in pthread_atfork -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define $ac_func to an innocuous variant, in case declares $ac_func. - For example, HP-UX 11i declares gettimeofday. */ -#define $ac_func innocuous_$ac_func - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $ac_func - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 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_exeext' - { (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 - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - fi cat >>confdefs.h <<\_ACEOF diff --git a/unix/configure.in b/unix/configure.in index e22a7d3..5a7125e 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -93,6 +93,7 @@ fi #------------------------------------------------------------------------ SC_ENABLE_THREADS +AC_CHECK_FUNCS(pthread_atfork) #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 @@ -513,7 +514,6 @@ if test "`uname -s`" = "Darwin" ; then if test $tcl_corefoundation = yes; then AC_CHECK_HEADERS(libkern/OSAtomic.h) AC_CHECK_FUNCS(OSSpinLockLock) - AC_CHECK_FUNCS(pthread_atfork) fi AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?]) AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8", diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index b6529c2..2fc1647 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -66,6 +66,8 @@ static int TestfilewaitCmd(ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv); static int TestfindexecutableCmd(ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv); +static int TestforkObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST *argv); static int TestgetopenfileCmd(ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv); static int TestgetdefencdirCmd(ClientData dummy, @@ -110,6 +112,8 @@ TclplatformtestInit( (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd, (ClientData) 0, NULL); + Tcl_CreateObjCommand(interp, "testfork", TestforkObjCmd, + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, @@ -533,6 +537,52 @@ TestsetdefencdirCmd( Tcl_SetDefaultEncodingDir(argv[1]); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestforkObjCmd -- + * + * This function implements the "testfork" command. It is used to + * fork the Tcl process for specific test cases. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestforkObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST *objv) /* Argument strings. */ +{ + pid_t pid; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + pid = fork(); + if (pid == -1) { + Tcl_AppendResult(interp, + "Cannot fork", NULL); + return TCL_ERROR; + } +#ifndef HAVE_PTHREAD_ATFORK + /* Only needed when pthread_atfork is not present. */ + if (pid==0) { + Tcl_InitNotifier(); + } +#endif + Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); + return TCL_OK; +} /* *---------------------------------------------------------------------- -- cgit v0.12 From c75e578cb3af78543a31ac6ad4676324c9ce6b6c Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 23 Jul 2013 18:01:36 +0000 Subject: Stop checking stack depth in [catch] compiler. Stack depth is checked in compiles of *all* Tcl commands/scripts/bodies in debug builds already. --- generic/tclCompCmds.c | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7fe0728..bde6f96 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -544,7 +544,6 @@ TclCompileCatchCmd( JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; int resultIndex, optsIndex, range; - int initStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ /* @@ -742,15 +741,6 @@ TclCompileCatchCmd( TclEmitOpcode( INST_POP, envPtr); } - /* - * Result of all this, on either branch, should have been to leave one - * operand -- the return code -- on the stack. - */ - - if (envPtr->currStackDepth != initStackDepth + 1) { - Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d", - envPtr->currStackDepth, initStackDepth+1); - } return TCL_OK; } -- cgit v0.12 From 717285df9ed06247a6236610722e8fd22d124464 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 23 Jul 2013 18:03:39 +0000 Subject: Remove outdated comment. Stack depths are well checked now. --- generic/tclCompCmdsSZ.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 320ed57..d8587be 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -991,9 +991,6 @@ TclSubstCompile( * Instructions are added to envPtr to execute the "switch" command at * runtime. * - * FIXME: - * Stack depths are probably not calculated correctly. - * *---------------------------------------------------------------------- */ -- cgit v0.12 From 1ea19bb4bad3984855b928d2a5213314b1111e47 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 23 Jul 2013 20:11:00 +0000 Subject: Remove outdated, disabled code. --- generic/tclCompile.c | 503 --------------------------------------------------- 1 file changed, 503 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a52ad3e..e4da2ba 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -16,8 +16,6 @@ #include "tclCompile.h" #include -#define REWRITE - /* * Table of all AuxData types. */ @@ -564,10 +562,6 @@ static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); -#ifndef REWRITE -static Command * FindCompiledCommandFromToken(Tcl_Interp *interp, - Tcl_Token *tokenPtr); -#endif static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); @@ -1672,56 +1666,6 @@ TclWordKnownAtCompileTime( return 1; } -#ifndef REWRITE -/* - * --------------------------------------------------------------------- - * - * FindCompiledCommandFromToken -- - * - * A simple helper that looks up a command's compiler from its token. - * - * --------------------------------------------------------------------- - */ - -static Command * -FindCompiledCommandFromToken( - Tcl_Interp *interp, - Tcl_Token *tokenPtr) -{ - Tcl_DString ds; - Command *cmdPtr; - - /* - * If we have a non-trivial token or are suppressing compilation, we stop - * right now. - */ - - if ((tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) - || (((Interp *) interp)->flags & DONT_COMPILE_CMDS_INLINE)) { - return NULL; - } - - /* - * We copy the string before trying to find the command by name. We used - * to modify the string in place, but this is not safe because the name - * resolution handlers could have side effects that rely on the unmodified - * string. - */ - - Tcl_DStringInit(&ds); - TclDStringAppendToken(&ds, &tokenPtr[1]); - cmdPtr = (Command *) Tcl_FindCommand(interp, Tcl_DStringValue(&ds), NULL, - /*flags*/ 0); - if (cmdPtr != NULL && (cmdPtr->compileProc == NULL - || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) - || (cmdPtr->flags & CMD_HAS_EXEC_TRACES))) { - cmdPtr = NULL; - } - Tcl_DStringFree(&ds); - return cmdPtr; -} -#endif - /* *---------------------------------------------------------------------- * @@ -1740,8 +1684,6 @@ FindCompiledCommandFromToken( *---------------------------------------------------------------------- */ -#ifdef REWRITE - static int ExpandRequested( Tcl_Token *tokenPtr, @@ -2071,7 +2013,6 @@ CompileCommandTokens( return cmdIdx; } -#endif void TclCompileScript( @@ -2084,7 +2025,6 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { -#ifdef REWRITE int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last * command this routine compiles into bytecode. * Initial value of -1 indicates this routine @@ -2198,449 +2138,6 @@ TclCompileScript( envPtr->codeNext--; envPtr->currStackDepth++; } -#else - int lastTopLevelCmdIndex = -1; - /* Index of most recent toplevel command in - * the command location table. Initialized to - * avoid compiler warning. */ - int startCodeOffset = -1; /* Offset of first byte of current command's - * code. Init. to avoid compiler warning. */ - unsigned char *entryCodeNext = envPtr->codeNext; - const char *p, *next; - Command *cmdPtr; - Tcl_Token *tokenPtr; - int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex; - /* TIP #280 */ - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; - int *wlines, wlineat, cmdLine, *clNext; - Tcl_Parse parse, *parsePtr = &parse; - - if (envPtr->iPtr == NULL) { - Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); - } - - if (numBytes < 0) { - numBytes = strlen(script); - } - Tcl_ResetResult(interp); - isFirstCmd = 1; - - /* - * Each iteration through the following loop compiles the next command - * from the script. - */ - - p = script; - bytesLeft = numBytes; - cmdLine = envPtr->line; - clNext = envPtr->clNext; - do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { - /* - * Compile bytecodes to report the parse error at runtime. - */ - - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - parsePtr->term + 1 - parsePtr->commandStart); - TclCompileSyntaxError(interp, envPtr); - break; - } - - /* - * TIP #280: We have to count newlines before the command even in the - * degenerate case when the command has no words. (See test - * info-30.33). - * So make that counting here, and not in the (numWords > 0) branch - * below. - */ - - TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); - TclAdvanceContinuations(&cmdLine, &clNext, - parsePtr->commandStart - envPtr->source); - - if (parsePtr->numWords > 0) { - int expand = 0; /* Set if there are dynamic expansions to - * handle */ - - /* - * If not the first command, pop the previous command's result - * and, if we're compiling a top level command, update the last - * command's code size to account for the pop instruction. - */ - - if (!isFirstCmd) { - TclEmitOpcode(INST_POP, envPtr); - envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - startCodeOffset; - } - - /* - * Determine the actual length of the command. - */ - - commandLength = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + commandLength-1) { - /* - * The command terminator character (such as ; or ]) is the - * last character in the parsed command. Reduce the length by - * one so that the trace message doesn't include the - * terminator character. - */ - - commandLength -= 1; - } - -#ifdef TCL_COMPILE_DEBUG - /* - * If tracing, print a line for each top level command compiled. - */ - - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parsePtr->commandStart, - TclMin(commandLength, 55)); - fprintf(stdout, "\n"); - } -#endif - - /* - * Check whether expansion has been requested for any of the - * words. - */ - - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - break; - } - } - - /* - * If expansion was requested, check if the command declares that - * it knows how to compile it. Note that if expansion is requested - * for the first word, this check will fail as the token type will - * inhibit it. (Checked inside FindCompiledCommandFromToken.) This - * is as it should be. - */ - - if (expand) { - cmdPtr = FindCompiledCommandFromToken(interp, - parsePtr->tokenPtr); - if (cmdPtr && (cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = 0; - } - } - - envPtr->numCommands++; - currCmdIndex = envPtr->numCommands - 1; - lastTopLevelCmdIndex = currCmdIndex; - startCodeOffset = envPtr->codeNext - envPtr->codeStart; - EnterCmdStartData(envPtr, currCmdIndex, - parsePtr->commandStart - envPtr->source, startCodeOffset); - - /* - * Should only start issuing instructions after the "command has - * started" so that the command range is correct in the bytecode. - */ - - if (expand) { - StartExpanding(envPtr); - } - - /* - * TIP #280. Scan the words and compute the extended location - * information. The map first contain full per-word line - * information for use by the compiler. This is later replaced by - * a reduced form which signals non-literal words, stored in - * 'wlines'. - */ - - EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->commandSize, parsePtr->numWords, cmdLine, - clNext, &wlines, envPtr); - wlineat = eclPtr->nuloc - 1; - - /* - * Each iteration of the following loop compiles one word from the - * command. - */ - - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; wordIdx++, - tokenPtr += tokenPtr->numComponents + 1) { - /* - * Note the parse location information. - */ - - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * The word is not a simple string of characters. - */ - - CompileTokens(envPtr, tokenPtr, interp); - if (expand && tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } - - /* - * This is a simple string of literal characters (i.e. we know - * it absolutely and can use it directly). If this is the - * first word and the command has a compile procedure, let it - * compile the command. - */ - - if ((wordIdx == 0) && !expand) { - cmdPtr = FindCompiledCommandFromToken(interp, tokenPtr); - if (cmdPtr) { - int savedNumCmds = envPtr->numCommands; - unsigned savedCodeNext = - envPtr->codeNext - envPtr->codeStart; - int update = 0; - int startStackDepth = envPtr->currStackDepth; - - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD - * in special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] - * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. - */ - - if (envPtr->atCmdStart == 1) { - if (savedCodeNext != 0) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) - } - } else if (envPtr->atCmdStart == 0) { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; - } - - if (cmdPtr->compileProc(interp, parsePtr, cmdPtr, - envPtr) == TCL_OK) { - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ - -#ifdef TCL_COMPILE_DEBUG - int diff = envPtr->currStackDepth-startStackDepth; - - if (diff != 1) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", - parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif - if (update) { - /* - * Fix the bytecode length. - */ - - unsigned char *fixPtr = envPtr->codeStart - + savedCodeNext + 1; - unsigned fixLen = envPtr->codeNext - - envPtr->codeStart - savedCodeNext; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } - - if (envPtr->atCmdStart == 1 && savedCodeNext != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); - } - - /* - * Restore numCommands and codeNext to their correct - * values, removing any commands compiled before the - * failure to produce bytecode got reported. [Bugs - * 705406 and 735055] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; - - /* - * And the stack depth too!! [Bug 3614102]. - */ - - envPtr->currStackDepth = startStackDepth; - } - - /* - * No compile procedure so push the word. If the command - * was found, push a CmdName object to reduce runtime - * lookups. Mark this as a command name literal to reduce - * shimmering. - */ - - objIndex = TclRegisterNewCmdLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (cmdPtr) { - TclSetCmdNameObj(interp, - TclFetchLiteral(envPtr, objIndex), cmdPtr); - } - } else { - /* - * Simple argument word of a command. We reach this if and - * only if the command word was not compiled for whatever - * reason. Register the literal's location for use by - * uplevel, etc. commands, should they encounter it - * unmodified. We care only if the we are in a context - * which already allows absolute counting. - */ - - objIndex = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - - if (envPtr->clNext) { - TclContinuationsEnterDerived( - TclFetchLiteral(envPtr, objIndex), - tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); - } - } - TclEmitPush(objIndex, envPtr); - } /* for loop */ - - /* - * Emit an invoke instruction for the command. We skip this if a - * compile procedure was found for the command. - */ - assert(wordIdx > 0); - - if (expand) { - /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. - * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). - * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. - */ - - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - envPtr->expandCount--; - TclAdjustStackDepth(1 - wordIdx, envPtr); - } else { - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ - - int isnew; - Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), - &isnew); - - Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); - if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); - } - } - - /* - * Update the compilation environment structure and record the - * offsets of the source and code for the command. - */ - - finishCommand: - EnterCmdExtentData(envPtr, currCmdIndex, commandLength, - (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - isFirstCmd = 0; - - /* - * TIP #280: Free full form of per-word line data and insert the - * reduced form now - */ - - ckfree(eclPtr->loc[wlineat].line); - ckfree(eclPtr->loc[wlineat].next); - eclPtr->loc[wlineat].line = wlines; - eclPtr->loc[wlineat].next = NULL; - } /* end if parsePtr->numWords > 0 */ - - /* - * Advance to the next command in the script. - */ - - next = parsePtr->commandStart + parsePtr->commandSize; - bytesLeft -= next - p; - p = next; - - /* - * TIP #280: Track lines in the just compiled command. - */ - - TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); - TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); - Tcl_FreeParse(parsePtr); - } while (bytesLeft > 0); - - /* - * TIP #280: Bring the line counts in the CompEnv up to date. - * See tests info-30.33,34,35 . - */ - - envPtr->line = cmdLine; - envPtr->clNext = clNext; - - /* - * If the source script yielded no instructions (e.g., if it was empty), - * push an empty string as the command's result. - */ - - if (envPtr->codeNext == entryCodeNext) { - PushStringLiteral(envPtr, ""); - } -#endif } /* -- cgit v0.12 From 8f13e41a87de841f8b7552e04e74caeaca8b4b5b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Jul 2013 12:13:01 +0000 Subject: more disabled code removal --- generic/tclAssembly.c | 7 ------- generic/tclEnsemble.c | 46 ---------------------------------------------- 2 files changed, 53 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 9b9b6f8..6bf2fa8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -930,11 +930,9 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ -#if 1 int numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; int depth = envPtr->currStackDepth; -#endif /* * Make sure that the command has a single arg that is a simple word. @@ -956,7 +954,6 @@ TclCompileAssembleCmd( if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, TCL_EVAL_DIRECT)) { -#if 1 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s\" body, line %d)", parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, @@ -965,10 +962,6 @@ TclCompileAssembleCmd( envPtr->codeNext = envPtr->codeStart + offset; envPtr->currStackDepth = depth; TclCompileSyntaxError(interp, envPtr); -#else - Tcl_ResetResult(interp); - return TCL_ERROR; -#endif } return TCL_OK; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index bab63c9..ad11785 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3205,7 +3205,6 @@ CompileBasicNArgCommand( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { -#if 1 Tcl_Obj *objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); @@ -3213,51 +3212,6 @@ CompileBasicNArgCommand( TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, parsePtr->numWords, envPtr); Tcl_DecrRefCount(objPtr); -#else - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - char *bytes; - int length, i, literal; - DefineLineInformation; - - /* - * Push the name of the command we're actually dispatching to as part of - * the implementation. - */ - - objPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, literal), cmdPtr); - TclEmitPush(literal, envPtr); - TclDecrRefCount(objPtr); - - /* - * Push the words of the command. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; inumWords ; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); - } else { - SetLineInformation(i); - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Do the standard dispatch. - */ - - if (i <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); - } -#endif return TCL_OK; } -- cgit v0.12 From f9e25fe5e7e67249f73b8f5926b3b5549c0e212e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Jul 2013 13:58:35 +0000 Subject: Mark commands with potential to compile expansion arguments (as [list] does). --- generic/tclCompCmds.c | 9 +++++++++ generic/tclCompCmdsGR.c | 4 ++++ generic/tclCompCmdsSZ.c | 5 +++++ 3 files changed, 18 insertions(+) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index bde6f96..8edb2d9 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -87,6 +87,7 @@ TclCompileAppendCmd( int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -973,6 +974,7 @@ TclCompileDictGetCmd( * case is legal, but too special and magic for us to deal with here). */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1010,6 +1012,7 @@ TclCompileDictExistsCmd( * case is legal, but too special and magic for us to deal with here). */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1047,6 +1050,7 @@ TclCompileDictUnsetCmd( * compile to bytecode. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1192,6 +1196,7 @@ TclCompileDictMergeCmd( * argument, the only thing to do is to verify the dict-ness. */ + /* TODO: Consider support for compiling expanded args. (less likely) */ if (parsePtr->numWords < 2) { PushStringLiteral(envPtr, ""); return TCL_OK; @@ -1712,6 +1717,7 @@ TclCompileDictAppendCmd( * speed quite so much. ;-) */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords<4 || parsePtr->numWords>100) { return TCL_ERROR; } @@ -1764,6 +1770,8 @@ TclCompileDictLappendCmd( * There must be three arguments after the command. */ + /* TODO: Consider support for compiling expanded args. */ + /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */ if (parsePtr->numWords != 4) { return TCL_ERROR; } @@ -1810,6 +1818,7 @@ TclCompileDictWithCmd( * There must be at least one argument after the command. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index fc68509..150c378 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -60,6 +60,7 @@ TclCompileGlobalCmd( int localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; @@ -820,6 +821,7 @@ TclCompileLappendCmd( return TCL_ERROR; } + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -1061,6 +1063,7 @@ TclCompileLindexCmd( * Quit if too few args. */ + /* TODO: Consider support for compiling expanded args. */ if (numWords <= 1) { return TCL_ERROR; } @@ -1583,6 +1586,7 @@ TclCompileLsetCmd( * Check argument count. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { /* * Fail at run time, not in compilation. diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d8587be..d1eb9db 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2818,6 +2818,7 @@ TclCompileUnsetCmd( Tcl_Obj *leadingWord; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords-1; flags = 1; varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -3173,6 +3174,7 @@ CompileAssociativeBinaryOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); @@ -3256,6 +3258,7 @@ CompileComparisonOpCmd( Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { PUSH("1"); } else if (parsePtr->numWords == 3) { @@ -3593,6 +3596,7 @@ TclCompileMinusOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. @@ -3638,6 +3642,7 @@ TclCompileDivOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. -- cgit v0.12 From 7682f9c4cd7dfb3439a27d03b4531358798ff443 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Jul 2013 16:51:04 +0000 Subject: Demonstrate and fix memory leak in Tcl_ParseVar(). --- generic/tclParse.c | 1 + tests/parse.test | 21 +++++++++++++++++++++ 2 files changed, 22 insertions(+) diff --git a/generic/tclParse.c b/generic/tclParse.c index 96c2a10..e475fb8 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1566,6 +1566,7 @@ Tcl_ParseVar( code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, NULL, 1, NULL, NULL); + Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); if (code != TCL_OK) { return NULL; diff --git a/tests/parse.test b/tests/parse.test index 4605914..d7de5ff 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -23,6 +23,7 @@ testConstraint testparsevarname [llength [info commands testparsevarname]] testConstraint testparsevar [llength [info commands testparsevar]] testConstraint testasync [llength [info commands testasync]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] +testConstraint memory [llength [info commands memory]] test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -674,6 +675,26 @@ test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar unset -nocomplain abc list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} +test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup { + proc getbytes {} { + return [lindex [split [memory info] \n] 3 3] + } +} -body { + set a() foo + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set vn {} + set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]] + if {$res ne {foo bar}} {error "Unexpected result: $res"} + + set tmp $end + set end [getbytes] + } + expr {$end - $tmp} +} -cleanup { + unset -nocomplain a end i vn res tmp + rename getbytes {} +} -result 0 test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 -- cgit v0.12 From e048f90718b9ad348b7ea46ad2196e19502042c1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Jul 2013 06:59:08 +0000 Subject: Put Cygwin's tclWinError.o in PLAT_OBJS, not in DL_OBJS --- unix/Makefile.in | 5 ++++- unix/configure | 3 ++- unix/tcl.m4 | 3 ++- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index b5ca879..163f4b5 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,7 +335,10 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o -STUB_LIB_OBJS = tclStubLib.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} +STUB_LIB_OBJS = tclStubLib.o \ + tclTomMathStubLib.o \ + tclOOStubLib.o \ + ${COMPAT_OBJS} UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ diff --git a/unix/configure b/unix/configure index ef47ac5..4d0ecef 100755 --- a/unix/configure +++ b/unix/configure @@ -7170,7 +7170,8 @@ fi SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" - DL_OBJS="tclLoadDl.o tclWinError.o" + DL_OBJS="tclLoadDl.o" + PLAT_OBJS="tclWinError.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index b9b6532..a95cf63 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1224,7 +1224,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" - DL_OBJS="tclLoadDl.o tclWinError.o" + DL_OBJS="tclLoadDl.o" + PLAT_OBJS="tclWinError.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" -- cgit v0.12 From 69fbd6c489ee246d40067e6a6394419ecb9a6b07 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Jul 2013 08:29:56 +0000 Subject: Make sure that the notifierMutex and notifierCV in a forked child cannot block anything, even though the initialization of the Notifier Thread in the parent is not finished yet. --- unix/tclUnixNotfy.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index f414c3f..ec721ca 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -1335,6 +1335,8 @@ AtForkParent(void) static void AtForkChild(void) { + notifierMutex = NULL; + notifierCV = NULL; Tcl_InitNotifier(); } #endif /* HAVE_PTHREAD_ATFORK */ -- cgit v0.12 From 7fb69e61c80a0f943d0cbc01e7f4ba39eb2cb737 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Jul 2013 14:24:39 +0000 Subject: Move test for pthread_atfork inside SC_ENABLE_THREADS --- unix/configure | 105 ++---------------------------------------------------- unix/configure.in | 1 - unix/tcl.m4 | 2 +- 3 files changed, 3 insertions(+), 105 deletions(-) diff --git a/unix/configure b/unix/configure index 9fa5673..217e5d4 100755 --- a/unix/configure +++ b/unix/configure @@ -4796,7 +4796,8 @@ echo "$as_me: WARNING: Don't know how to find pthread lib on your system - you m ac_saved_libs=$LIBS LIBS="$LIBS $THREADS_LIBS" -for ac_func in pthread_attr_setstacksize + +for ac_func in pthread_attr_setstacksize pthread_atfork do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 @@ -5303,108 +5304,6 @@ echo "${ECHO_T}no (default)" >&6 -for ac_func in pthread_atfork -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define $ac_func to an innocuous variant, in case declares $ac_func. - For example, HP-UX 11i declares gettimeofday. */ -#define $ac_func innocuous_$ac_func - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $ac_func - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 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_exeext' - { (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 - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - - #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 5a7125e..37de8be 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -93,7 +93,6 @@ fi #------------------------------------------------------------------------ SC_ENABLE_THREADS -AC_CHECK_FUNCS(pthread_atfork) #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 879d810..f484989 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -679,7 +679,7 @@ AC_DEFUN([SC_ENABLE_THREADS], [ ac_saved_libs=$LIBS LIBS="$LIBS $THREADS_LIBS" - AC_CHECK_FUNCS(pthread_attr_setstacksize) + AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork) AC_CHECK_FUNC(pthread_attr_get_np,tcl_ok=yes,tcl_ok=no) if test $tcl_ok = yes ; then AC_DEFINE(HAVE_PTHREAD_ATTR_GET_NP, 1, -- cgit v0.12 From 9b087e12907c940eed87b510213ca363ef8d5a4b Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 25 Jul 2013 17:20:02 +0000 Subject: Fixed test case variable clash with 'folder' --- tests/unixForkEvent.test | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test index a0c3f19..cbe582e 100644 --- a/tests/unixForkEvent.test +++ b/tests/unixForkEvent.test @@ -18,27 +18,27 @@ testConstraint testfork [llength [info commands testfork]] test unixforkevent-1.1 {fork and test writeable event} \ -constraints testfork \ -body { - set folder [makeDirectory unixtestfork] + set myFolder [makeDirectory unixtestfork] set pid [testfork] if {$pid == 0} { # we are the forked process set result initialized - set h [open [file join $folder test.txt] w] + set h [open [file join $myFolder test.txt] w] fileevent $h writable\ "set result writable;\ after cancel [after 1000 {set result timeout}]" vwait result close $h - makeFile $result result.txt $folder + makeFile $result result.txt $myFolder exit } # we are the original process - while {![file readable [file join $folder result.txt]]} {} - viewFile result.txt $folder + while {![file readable [file join $myFolder result.txt]]} {} + viewFile result.txt $myFolder } \ -result {writable} \ -cleanup { - catch { removeFolder $folder } + catch { removeFolder $myFolder } } ::tcltest::cleanupTests -- cgit v0.12 From c86bd1b78ad2eec0899db1c0927048cf9f0ed435 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 26 Jul 2013 13:21:30 +0000 Subject: [6585b21ca8] [regexp {(\w).*?\1} abb] failed to match. Thanks to Tom Lane for passing on the discovery in Postgres. --- generic/regexec.c | 7 +------ tests/regexp.test | 4 ++++ 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/generic/regexec.c b/generic/regexec.c index c902209..205fcc2 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -512,12 +512,7 @@ cfindloop( return er; } if ((shorter) ? end == estop : end == begin) { - /* - * No point in trying again. - */ - - *coldp = cold; - return REG_NOMATCH; + break; } /* diff --git a/tests/regexp.test b/tests/regexp.test index 8138054..362f425 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -728,6 +728,10 @@ test regexp-22.5 {Bug 3610026} -setup { } -cleanup { unset -nocomplain e cp } -returnCodes error -match glob -result {*too many colors*} +test regexp-22.6 {Bug 6585b21ca8} { + expr {[regexp {(\w).*?\1} Programmer m] ? $m : ""} +} rogr + test regexp-23.1 {regexp -all and -line} { set string "" -- cgit v0.12 From 83bd34e627b2f9c0c0b5fe3917e82f3428dc9565 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 27 Jul 2013 20:29:42 +0000 Subject: Simplify AuxData access with a macro. --- generic/tclAssembly.c | 2 +- generic/tclCompile.c | 1 + generic/tclCompile.h | 9 +++++++++ tests/subst.test | 4 ++++ 4 files changed, 15 insertions(+), 1 deletion(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 6bf2fa8..100e9ef 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -3047,7 +3047,7 @@ ResolveJumpTableTargets( auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", bbPtr, bbPtr->jumpOffset, auxDataIndex); - realJumpTablePtr = envPtr->auxDataArrayPtr[auxDataIndex].clientData; + realJumpTablePtr = TclFetchAuxData(envPtr, auxDataIndex); realJumpHashPtr = &realJumpTablePtr->hashTable; /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index e4da2ba..772ce22 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2055,6 +2055,7 @@ TclCompileScript( #ifdef TCL_COMPILE_DEBUG /* * If tracing, print a line for each top level command compiled. + * TODO: Suppress when numWords == 0 ? */ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 56315db..beb28fd 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1113,6 +1113,15 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); *---------------------------------------------------------------- */ +/* + * Simplified form to access AuxData. + * + * ClientData TclFetchAuxData(CompileEng *envPtr, int index); + */ + +#define TclFetchAuxData(envPtr, index) \ + (envPtr)->auxDataArrayPtr[(index)].clientData + #define LITERAL_ON_HEAP 0x01 #define LITERAL_CMD_NAME 0x02 diff --git a/tests/subst.test b/tests/subst.test index 4be4798..7466895 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -293,6 +293,10 @@ test subst-13.1 {Bug 3081065} -setup { } -cleanup { removeFile subst13.tcl } +test subst-13.2 {Test for segfault} -body { + subst {[} +} -returnCodes error -result * -match glob + # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 35f064fd91f1a987c493f4740df59d3a0f162a42 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 29 Jul 2013 09:29:16 +0000 Subject: Make sure that "string is space \u202f" will continue to return "1", even if in future Unicode this character (NARROW_NO_BREAK_SPACE) will cease to be a space. See: [http://www.unicode.org/review/pri249/] --- generic/tclUtf.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index a038f8a..e5497a4 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1555,7 +1555,7 @@ Tcl_UniCharIsSpace( if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { return TclIsSpaceProc((char) ch); - } else if ((Tcl_UniChar) ch == 0x180e) { + } else if ((Tcl_UniChar) ch == 0x180e || (Tcl_UniChar) ch == 0x202f) { return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); -- cgit v0.12 From 2145004977c06c1989ad5ad0ee2d800da3353001 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 1 Aug 2013 19:18:02 +0000 Subject: [1905562] [8d2c0da36d] Raise the recursion limits on regexps to allow existing regexps "in the wild" to continue working with Tcl 8.6. Latest example comes from DejaGnu. --- generic/regc_nfa.c | 2 +- tests/reg.test | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index fc0c823..42489dd 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -824,7 +824,7 @@ duptraverse( * make all normal tests (not reg-33.14) pass. */ #ifndef DUPTRAVERSE_MAX_DEPTH -#define DUPTRAVERSE_MAX_DEPTH 700 +#define DUPTRAVERSE_MAX_DEPTH 15000 #endif if (depth++ > DUPTRAVERSE_MAX_DEPTH) { diff --git a/tests/reg.test b/tests/reg.test index 559f549..e6ce42c 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -1155,6 +1155,9 @@ test reg-33.15 {Bug 3603557 - an "in the wild" RE} { (.*) # ConditionalFields }] 0 } 68 +test reg-33.16 {Bug [8d2c0da36d]- another "in the wild" RE} { + lindex [regexp -about "^MRK:client1: =1339 14HKelly Talisman 10011000 (\[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]*) \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 8 0 8 0 0 0 77 77 1 1 2 0 11 { 1 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 13HC6 My Creator 2 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 31HC7 Slightly offensive name, huh 3 8 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 23HE-mail:kelly@hotbox.com 4 9 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 17Hcompface must die 5 10 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 3HAir 6 12 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 14HPGP public key 7 13 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 16Hkelly@hotbox.com 8 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 12H2 text/plain 9 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 13H2 x-kom/basic 10 33 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H0 11 14 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H3 }\r?"] 0 +} 1 # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 6af366a7dcf18d187e53d5e58264b34675b31d22 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Aug 2013 14:58:58 +0000 Subject: [9d61624b3d]: Stop crashes when emptying the superclass slot. --- generic/tclOODefineCmds.c | 48 ++++++++++++++++++++++++++++------------------- tests/oo.test | 17 +++++++++++++++++ 2 files changed, 46 insertions(+), 19 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index bacab38..1a5058c 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2206,29 +2206,39 @@ ClassSuperSet( /* * Parse the arguments to get the class to use as superclasses. + * + * Note that zero classes is special, as it is equivalent to just the + * class of objects. [Bug 9d61624b3d] */ - for (i=0 ; ifPtr->objectCls; + superc = 1; + } else { + for (i=0 ; iclassPtr, superclasses[i])) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to form circular dependency graph", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); - failedAfterAlloc: - ckfree((char *) superclasses); - return TCL_ERROR; + for (j=0 ; jclassPtr, superclasses[i])) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to form circular dependency graph", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); + failedAfterAlloc: + ckfree((char *) superclasses); + return TCL_ERROR; + } } } diff --git a/tests/oo.test b/tests/oo.test index 49fe150..6f16a8d 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3374,6 +3374,23 @@ test oo-34.8 {TIP 380: slots - presence} { test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -clear -set} {Get Set}} + +test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { + oo::class create fruit { + method eat {} {} + } + set result {} +} -body { + lappend result [fruit create ::apple] [info class superclasses fruit] + oo::define fruit superclass + lappend result [info class superclasses fruit] \ + [info object class apple oo::object] \ + [info class call fruit destroy] \ + [catch { apple }] +} -cleanup { + unset -nocomplain result + fruit destroy +} -result {::apple ::oo::object ::oo::object 1 {{method destroy ::oo::object {core method: "destroy"}}} 1} cleanupTests return -- cgit v0.12 From ed2e06d4526c12d6cb4c559b6746216396ca4a10 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Aug 2013 20:19:44 +0000 Subject: Deal with the elaborate rip-apart-a-metaclass case as well. --- ChangeLog | 11 ++++++++--- generic/tclOODefineCmds.c | 3 +++ tests/oo.test | 19 +++++++++++++++++++ 3 files changed, 30 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index b794da5..a82dbfd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,8 +1,13 @@ +2013-08-02 Donal Fellows + + * generic/tclOODefineCmds.c (ClassSuperSet): Bug [9d61624b3d]: Stop + crashes when emptying the superclass slot, even when doing elaborate + things with metaclasses. + 2013-08-01 Harald Oehlmann - * tclUnixNotify.c Tcl_InitNotifier: Bug [a0bc856dcd] - Start notifier thread again if we were forked, to solve Rivet bug - 55153. + * tclUnixNotify.c (Tcl_InitNotifier): Bug [a0bc856dcd]: Start notifier + thread again if we were forked, to solve Rivet bug 55153. 2013-07-05 Kevin B. Kenny diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 1a5058c..f0983cc 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2215,6 +2215,9 @@ ClassSuperSet( superclasses = ckrealloc(superclasses, sizeof(Class *)); superclasses[0] = oPtr->fPtr->objectCls; superc = 1; + if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { + superclasses[0] = oPtr->fPtr->classCls; + } } else { for (i=0 ; i Date: Sat, 3 Aug 2013 15:27:40 +0000 Subject: [3611643fff]: Support TclOO in autoload mechanism. --- ChangeLog | 5 +++++ library/auto.tcl | 14 ++++++++++++++ 2 files changed, 19 insertions(+) diff --git a/ChangeLog b/ChangeLog index a82dbfd..ddde893 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-08-03 Donal Fellows + + * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found + by the autoloading mechanism. + 2013-08-02 Donal Fellows * generic/tclOODefineCmds.c (ClassSuperSet): Bug [9d61624b3d]: Stop diff --git a/library/auto.tcl b/library/auto.tcl index 0848bb1..78c219e 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -617,4 +617,18 @@ auto_mkindex_parser::command namespace {op args} { } } +# AUTO MKINDEX: oo::class create name ?definition? +# Adds an entry to the auto index list for the given class name. +foreach cmd {oo::class class} { + auto_mkindex_parser::command $cmd {ecmd name {body ""}} { + if {$cmd eq "create"} { + variable index + variable scriptFile + append index [format "set %s \[list source \[%s]]\n" \ + [list auto_index([fullname $name])] \ + [list file join $dir {*}[file split $scriptFile]]] + } + } +} + return -- cgit v0.12 From 4fa8d0b58071c8c666a320ef21813e12303c3564 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 5 Aug 2013 21:58:21 +0000 Subject: Mark unixforkevent-1.1 nonPortable, until proven on more platforms. --- tests/unixForkEvent.test | 2 +- unix/tclUnixTest.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test index cbe582e..120f362 100644 --- a/tests/unixForkEvent.test +++ b/tests/unixForkEvent.test @@ -16,7 +16,7 @@ testConstraint testfork [llength [info commands testfork]] # Test if the notifier thread is well initialized in a forked interpreter # by Tcl_InitNotifier test unixforkevent-1.1 {fork and test writeable event} \ - -constraints testfork \ + -constraints {testfork nonPortable} \ -body { set myFolder [makeDirectory unixtestfork] set pid [testfork] diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 2fc1647..d2b729d 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -574,8 +574,8 @@ TestforkObjCmd( "Cannot fork", NULL); return TCL_ERROR; } -#ifndef HAVE_PTHREAD_ATFORK - /* Only needed when pthread_atfork is not present. */ +#if !defined(HAVE_PTHREAD_ATFORK) || defined(MAC_OSX_TCL) + /* Only needed when pthread_atfork is not present or on OSX. */ if (pid==0) { Tcl_InitNotifier(); } -- cgit v0.12 From b3b497f42cfe1a533488c23fb8dfd706e7bb59a6 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Aug 2013 04:15:16 +0000 Subject: The value TCL_LOCATION_EVAL_LIST in the type field of a CmdFrame appears to exist only for the sake of taking great pains to make sure that pure list values remain pure list values. The value of pure list values is no longer what it once was. For a long long time now, any canonical list values have been equally good. This branch is Work In Progress eliminating the complication of the additional type value. Currently some minor botches are breaking execution tracing tests. --- generic/tclBasic.c | 67 ++++++++++++++++++---------------------------------- generic/tclCmdIL.c | 25 ++++---------------- generic/tclCompile.c | 2 +- generic/tclInt.h | 41 +++++++++++++++----------------- 4 files changed, 48 insertions(+), 87 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 82affb0..280835c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -128,7 +128,7 @@ static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, - Tcl_Obj *const objv[], int lookup); + Tcl_Obj *const objv[]); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; @@ -3358,15 +3358,6 @@ CancelEvalProc( * This function returns a Tcl_Obj with the full source string for the * command. This insures that traces get a correct NUL-terminated command * string. The Tcl_Obj has refCount==1. - * - * *** MAINTAINER WARNING *** - * The returned Tcl_Obj is all wrong for any purpose but getting the - * source string for an objc/objv command line in the stringRep (no - * stringRep if no source is available) and the corresponding substituted - * version in the List intrep. - * This means that the intRep and stringRep DO NOT COINCIDE! Using these - * Tcl_Objs normally is likely to break things. - * *---------------------------------------------------------------------- */ @@ -3374,37 +3365,27 @@ static Tcl_Obj * GetCommandSource( Interp *iPtr, int objc, - Tcl_Obj *const objv[], - int lookup) + Tcl_Obj *const objv[]) { - Tcl_Obj *objPtr, *obj2Ptr; + Tcl_Obj *objPtr = NULL; CmdFrame *cfPtr = iPtr->cmdFramePtr; - const char *command = NULL; - int numChars; - objPtr = Tcl_NewListObj(objc, objv); - if (lookup && cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) { + if (cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) { switch (cfPtr->type) { case TCL_LOCATION_EVAL: case TCL_LOCATION_SOURCE: - command = cfPtr->cmd.str.cmd; - numChars = cfPtr->cmd.str.len; + objPtr = Tcl_NewStringObj(cfPtr->cmd.str.cmd, cfPtr->cmd.str.len); break; case TCL_LOCATION_BC: - case TCL_LOCATION_PREBC: - command = TclGetSrcInfoForCmd(iPtr, &numChars); - break; - case TCL_LOCATION_EVAL_LIST: - /* Got it already */ + case TCL_LOCATION_PREBC: { + int numChars; + objPtr = Tcl_NewStringObj(TclGetSrcInfoForCmd(iPtr, &numChars), + numChars); break; } - if (command) { - obj2Ptr = Tcl_NewStringObj(command, numChars); - objPtr->bytes = obj2Ptr->bytes; - objPtr->length = numChars; - obj2Ptr->bytes = NULL; - Tcl_DecrRefCount(obj2Ptr); } + } else { + objPtr = Tcl_NewListObj(objc, objv); } Tcl_IncrRefCount(objPtr); return objPtr; @@ -4692,7 +4673,7 @@ TEOV_RunEnterTraces( int length; Tcl_Obj *commandPtr; - commandPtr = GetCommandSource(iPtr, objc, objv, 1); + commandPtr = GetCommandSource(iPtr, objc, objv); command = Tcl_GetStringFromObj(commandPtr, &length); /* @@ -4731,7 +4712,7 @@ TEOV_RunEnterTraces( */ TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), - commandPtr, cmdPtr, NULL); + commandPtr, cmdPtr, Tcl_NewListObj(objc, objv)); cmdPtr->refCount++; } else { Tcl_DecrRefCount(commandPtr); @@ -4752,10 +4733,11 @@ TEOV_RunLeaveTraces( int traceCode = PTR2INT(data[0]); Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; + Tcl_Obj *wordsPtr = data[3]; command = Tcl_GetStringFromObj(commandPtr, &length); - if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) { - Tcl_Panic("Who messed with commandPtr?"); + if (TCL_OK != Tcl_ListObjGetElements(interp, wordsPtr, &objc, &objv)) { + Tcl_Panic("What happened with wordsPtr?!"); } if (!(cmdPtr->flags & CMD_IS_DELETED)) { @@ -4769,6 +4751,7 @@ TEOV_RunLeaveTraces( } } Tcl_DecrRefCount(commandPtr); + Tcl_DecrRefCount(wordsPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. @@ -5974,13 +5957,12 @@ TclNREvalObjEx( */ if (TclListObjIsCanonical(objPtr)) { - Tcl_Obj *listPtr = objPtr; CmdFrame *eoFramePtr = NULL; int objc; - Tcl_Obj **objv; + Tcl_Obj *listPtr, **objv; /* - * Pure List Optimization (no string representation). In this case, we + * Canonical List Optimization: In this case, we * can safely use Tcl_EvalObjv instead and get an appreciable * improvement in execution speed. This is because it allows us to * avoid a setFromAny step that would just pack everything into a @@ -5988,11 +5970,6 @@ TclNREvalObjEx( * * This also preserves any associations between list elements and * location information for such elements. - * - * This restriction has been relaxed a bit by storing in lists whether - * they are "canonical" or not (a canonical list being one that is - * either pure or that has its string rep derived by - * UpdateStringOfList from the internal rep). */ /* @@ -6001,6 +5978,7 @@ TclNREvalObjEx( * we always make a copy. The callback takes care od the refCounts for * both listPtr and objPtr. * + * TODO: Create a test to demo this need, or eliminate it. * FIXME OPT: preserve just the internal rep? */ @@ -6030,14 +6008,15 @@ TclNREvalObjEx( eoFramePtr->nline = 0; eoFramePtr->line = NULL; - eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->type = TCL_LOCATION_EVAL; eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 : iPtr->cmdFramePtr->level + 1); eoFramePtr->numLevels = iPtr->numLevels; eoFramePtr->framePtr = iPtr->framePtr; eoFramePtr->nextPtr = iPtr->cmdFramePtr; - eoFramePtr->cmd.listPtr = listPtr; + eoFramePtr->cmd.str.cmd = Tcl_GetStringFromObj(listPtr, + &(eoFramePtr->cmd.str.len)); eoFramePtr->data.eval.path = NULL; iPtr->cmdFramePtr = eoFramePtr; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 0e33392..4046903 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1302,30 +1302,15 @@ TclInfoFrame( */ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + if (framePtr->line) { + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + } else { + ADD_PAIR("line", Tcl_NewIntObj(1)); + } ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, framePtr->cmd.str.len)); break; - case TCL_LOCATION_EVAL_LIST: - /* - * List optimized evaluation. Type, line, cmd, the latter through - * listPtr, possibly a frame. - */ - - ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewIntObj(1)); - - /* - * We put a duplicate of the command list obj into the result to - * ensure that the 'pure List'-property of the command itself is not - * destroyed. Otherwise the query here would disable the list - * optimization path in Tcl_EvalObjEx. - */ - - ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr)); - break; - case TCL_LOCATION_PREBC: /* * Precompiled. Result contains the type as signal, nothing else. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 772ce22..618b6fa 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1375,7 +1375,7 @@ TclInitCompileEnv( envPtr->extCmdMapPtr->nuloc = 0; envPtr->extCmdMapPtr->path = NULL; - if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) { + if (invoker == NULL) { /* * Initialize the compiler for relative counting in case of a * dynamic context. diff --git a/generic/tclInt.h b/generic/tclInt.h index da09366..1df09b3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1175,29 +1175,27 @@ typedef struct CmdFrame { * * EXECUTION CONTEXTS and usage of CmdFrame * - * Field TEBC EvalEx EvalObjEx - * ======= ==== ====== ========= - * level yes yes yes - * type BC/PREBC SRC/EVAL EVAL_LIST - * line0 yes yes yes - * framePtr yes yes yes - * ======= ==== ====== ========= + * Field TEBC EvalEx + * ======= ==== ====== + * level yes yes + * type BC/PREBC SRC/EVAL + * line0 yes yes + * framePtr yes yes + * ======= ==== ====== * - * ======= ==== ====== ========= union data - * line1 - yes - - * line3 - yes - - * path - yes - - * ------- ---- ------ --------- - * codePtr yes - - - * pc yes - - - * ======= ==== ====== ========= + * ======= ==== ========= union data + * line1 - yes + * line3 - yes + * path - yes + * ------- ---- ------ + * codePtr yes - + * pc yes - + * ======= ==== ====== * - * ======= ==== ====== ========= | union cmd - * listPtr - - yes | - * ------- ---- ------ --------- | - * cmd yes yes - | - * cmdlen yes yes - | - * ------- ---- ------ --------- | + * ======= ==== ========= union cmd + * str.cmd yes yes + * str.len yes yes + * ------- ---- ------ */ union { @@ -1215,7 +1213,6 @@ typedef struct CmdFrame { const char *cmd; /* The executed command, if possible... */ int len; /* ... and its length. */ } str; - Tcl_Obj *listPtr; /* Tcl_EvalObjEx, cmd list. */ } cmd; int numLevels; /* Value of interp's numLevels when the frame * was pushed. */ -- cgit v0.12 From 90aed79bb65a5df8dfc953a51ed832a8da563df4 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Aug 2013 13:08:54 +0000 Subject: Revert the changes that went too far and broke things. --- generic/tclBasic.c | 39 ++++++++++++++++++++++++++------------- 1 file changed, 26 insertions(+), 13 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 280835c..ea08f88 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3358,6 +3358,15 @@ CancelEvalProc( * This function returns a Tcl_Obj with the full source string for the * command. This insures that traces get a correct NUL-terminated command * string. The Tcl_Obj has refCount==1. + * + * *** MAINTAINER WARNING *** + * The returned Tcl_Obj is all wrong for any purpose but getting the + * source string for an objc/objv command line in the stringRep (no + * stringRep if no source is available) and the corresponding substituted + * version in the List intrep. + * This means that the intRep and stringRep DO NOT COINCIDE! Using these + * Tcl_Objs normally is likely to break things. + * *---------------------------------------------------------------------- */ @@ -3367,25 +3376,31 @@ GetCommandSource( int objc, Tcl_Obj *const objv[]) { - Tcl_Obj *objPtr = NULL; + Tcl_Obj *objPtr, *obj2Ptr; CmdFrame *cfPtr = iPtr->cmdFramePtr; + const char *command = NULL; + int numChars; + objPtr = Tcl_NewListObj(objc, objv); if (cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) { switch (cfPtr->type) { case TCL_LOCATION_EVAL: case TCL_LOCATION_SOURCE: - objPtr = Tcl_NewStringObj(cfPtr->cmd.str.cmd, cfPtr->cmd.str.len); + command = cfPtr->cmd.str.cmd; + numChars = cfPtr->cmd.str.len; break; case TCL_LOCATION_BC: - case TCL_LOCATION_PREBC: { - int numChars; - objPtr = Tcl_NewStringObj(TclGetSrcInfoForCmd(iPtr, &numChars), - numChars); + case TCL_LOCATION_PREBC: + command = TclGetSrcInfoForCmd(iPtr, &numChars); break; } + if (command) { + obj2Ptr = Tcl_NewStringObj(command, numChars); + objPtr->bytes = obj2Ptr->bytes; + objPtr->length = numChars; + obj2Ptr->bytes = NULL; + Tcl_DecrRefCount(obj2Ptr); } - } else { - objPtr = Tcl_NewListObj(objc, objv); } Tcl_IncrRefCount(objPtr); return objPtr; @@ -4712,7 +4727,7 @@ TEOV_RunEnterTraces( */ TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), - commandPtr, cmdPtr, Tcl_NewListObj(objc, objv)); + commandPtr, cmdPtr, NULL); cmdPtr->refCount++; } else { Tcl_DecrRefCount(commandPtr); @@ -4733,11 +4748,10 @@ TEOV_RunLeaveTraces( int traceCode = PTR2INT(data[0]); Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; - Tcl_Obj *wordsPtr = data[3]; command = Tcl_GetStringFromObj(commandPtr, &length); - if (TCL_OK != Tcl_ListObjGetElements(interp, wordsPtr, &objc, &objv)) { - Tcl_Panic("What happened with wordsPtr?!"); + if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) { + Tcl_Panic("Who messed with commandPtr?"); } if (!(cmdPtr->flags & CMD_IS_DELETED)) { @@ -4751,7 +4765,6 @@ TEOV_RunLeaveTraces( } } Tcl_DecrRefCount(commandPtr); - Tcl_DecrRefCount(wordsPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. -- cgit v0.12 From 2fa3c7789bf50168600e5ba432c5bcb1ea3a5c81 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Aug 2013 13:20:36 +0000 Subject: Eliminate the union that is no longer needed. --- generic/tclBasic.c | 13 ++++++------- generic/tclCmdIL.c | 9 +++------ generic/tclExecute.c | 14 +++++++------- generic/tclInt.h | 8 ++------ generic/tclOOMethod.c | 8 ++++---- generic/tclProc.c | 8 ++++---- 6 files changed, 26 insertions(+), 34 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ea08f88..baa2f2c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3386,8 +3386,8 @@ GetCommandSource( switch (cfPtr->type) { case TCL_LOCATION_EVAL: case TCL_LOCATION_SOURCE: - command = cfPtr->cmd.str.cmd; - numChars = cfPtr->cmd.str.len; + command = cfPtr->cmd; + numChars = cfPtr->len; break; case TCL_LOCATION_BC: case TCL_LOCATION_PREBC: @@ -5246,12 +5246,12 @@ TclEvalEx( * have been executed. */ - eeFramePtr->cmd.str.cmd = parsePtr->commandStart; - eeFramePtr->cmd.str.len = parsePtr->commandSize; + eeFramePtr->cmd = parsePtr->commandStart; + eeFramePtr->len = parsePtr->commandSize; if (parsePtr->term == parsePtr->commandStart + parsePtr->commandSize - 1) { - eeFramePtr->cmd.str.len--; + eeFramePtr->len--; } eeFramePtr->nline = objectsUsed; @@ -6028,8 +6028,7 @@ TclNREvalObjEx( eoFramePtr->framePtr = iPtr->framePtr; eoFramePtr->nextPtr = iPtr->cmdFramePtr; - eoFramePtr->cmd.str.cmd = Tcl_GetStringFromObj(listPtr, - &(eoFramePtr->cmd.str.len)); + eoFramePtr->cmd = Tcl_GetStringFromObj(listPtr, &(eoFramePtr->len)); eoFramePtr->data.eval.path = NULL; iPtr->cmdFramePtr = eoFramePtr; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 4046903..180d814 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1307,8 +1307,7 @@ TclInfoFrame( } else { ADD_PAIR("line", Tcl_NewIntObj(1)); } - ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, - framePtr->cmd.str.len)); + ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd, framePtr->len)); break; case TCL_LOCATION_PREBC: @@ -1356,8 +1355,7 @@ TclInfoFrame( Tcl_DecrRefCount(fPtr->data.eval.path); } - ADD_PAIR("cmd", - Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); + ADD_PAIR("cmd", Tcl_NewStringObj(fPtr->cmd, fPtr->len)); TclStackFree(interp, fPtr); break; } @@ -1376,8 +1374,7 @@ TclInfoFrame( * the result list object. */ - ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, - framePtr->cmd.str.len)); + ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd, framePtr->len)); break; case TCL_LOCATION_PROC: diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f8ed667..11e9920 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2006,8 +2006,8 @@ TclNRExecuteByteCode( bcFramePtr->litarg = NULL; bcFramePtr->data.tebc.codePtr = codePtr; bcFramePtr->data.tebc.pc = NULL; - bcFramePtr->cmd.str.cmd = NULL; - bcFramePtr->cmd.str.len = 0; + bcFramePtr->cmd = NULL; + bcFramePtr->len = 0; #ifdef TCL_COMPILE_STATS iPtr->stats.numExecutions++; @@ -8774,13 +8774,13 @@ TclGetSrcInfoForPc( { ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - if (cfPtr->cmd.str.cmd == NULL) { - cfPtr->cmd.str.cmd = GetSrcInfoForPc( + if (cfPtr->cmd == NULL) { + cfPtr->cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->cmd.str.len, NULL, NULL); + &cfPtr->len, NULL, NULL); } - if (cfPtr->cmd.str.cmd != NULL) { + if (cfPtr->cmd != NULL) { /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. @@ -8797,7 +8797,7 @@ TclGetSrcInfoForPc( return; } - srcOffset = cfPtr->cmd.str.cmd - codePtr->source; + srcOffset = cfPtr->cmd - codePtr->source; eclPtr = Tcl_GetHashValue(hePtr); for (i=0; i < eclPtr->nuloc; i++) { diff --git a/generic/tclInt.h b/generic/tclInt.h index 1df09b3..d398591 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1208,12 +1208,8 @@ typedef struct CmdFrame { const char *pc; /* ... and instruction pointer. */ } tebc; } data; - union { - struct { - const char *cmd; /* The executed command, if possible... */ - int len; /* ... and its length. */ - } str; - } cmd; + const char *cmd; /* The executed command, if possible... */ + int len; /* ... and its length. */ int numLevels; /* Value of interp's numLevels when the frame * was pushed. */ const struct CFWordBC *litarg; diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 98b4078..b91fdfd 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -513,8 +513,8 @@ TclOOMakeProcInstanceMethod( cfPtr->data.eval.path = context.data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew); @@ -626,8 +626,8 @@ TclOOMakeProcMethod( cfPtr->data.eval.path = context.data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew); diff --git a/generic/tclProc.c b/generic/tclProc.c index 18985a1..1314719 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -271,8 +271,8 @@ Tcl_ProcObjCmd( cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr, &isNew); @@ -2595,8 +2595,8 @@ SetLambdaFromAny( cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; } /* -- cgit v0.12 From c13bb10d72906770febda3135e8407326a24663c Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Aug 2013 13:30:36 +0000 Subject: Drop TCL_LOCATION_EVAL_LIST now that it is unused. --- generic/tclInt.h | 4 ---- 1 file changed, 4 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index d398591..cd4ab7d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1275,8 +1275,6 @@ typedef struct ContLineLoc { * location data referenced via the 'baseLocPtr'. * * TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx. - * TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list - * optimization path of EvalObjEx. * TCL_LOCATION_BC : Frame is for bytecode. * TCL_LOCATION_PREBC : Frame is for precompiled bytecode. * TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx, from a @@ -1288,8 +1286,6 @@ typedef struct ContLineLoc { */ #define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script. */ -#define TCL_LOCATION_EVAL_LIST (1) /* Location in a dynamic eval script, - * list-path. */ #define TCL_LOCATION_BC (2) /* Location in byte code. */ #define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no * location. */ -- cgit v0.12 From f56c89a9c1633b26c4f2ef5a898a92e0331ce678 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Aug 2013 16:20:59 +0000 Subject: Add assertions that will guide and protect more discovery of dead code for elimination. --- generic/tclBasic.c | 2 ++ generic/tclExecute.c | 8 +++++--- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index baa2f2c..1889dfd 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6109,6 +6109,8 @@ TclNREvalObjEx( ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; ContLineLoc *clLocPtr = TclContinuationsGet(objPtr); + assert(invoker == NULL); + if (clLocPtr) { iPtr->scriptCLLocPtr = clLocPtr; Tcl_Preserve(iPtr->scriptCLLocPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 11e9920..f6072a1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8774,13 +8774,15 @@ TclGetSrcInfoForPc( { ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - if (cfPtr->cmd == NULL) { + assert(cfPtr->type == TCL_LOCATION_BC); + assert(cfPtr->cmd == NULL); + cfPtr->cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); - } - if (cfPtr->cmd != NULL) { + assert(cfPtr->cmd != NULL); + { /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. -- cgit v0.12 From 854ba0e8ca16a91d958a52579e03b86d868fc8ca Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Aug 2013 17:24:40 +0000 Subject: All use of the evalFlag value TCL_EVAL_CTX is unused by the code and unreachable by extensions. This checkin removes all the code supporting that flag value. The consequence is that all the calls to TclNREvalObjEx() and its callers that are currently choosing not to pass the TCL_EVAL_DIRECT flag in when they pass in a non-NULL invoker will no longer be free to change their mind. That might be reason not to adopt this change. --- generic/tclBasic.c | 98 ++++++------------------------------------------------ generic/tclInt.h | 1 - 2 files changed, 11 insertions(+), 88 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1889dfd..00ae24e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5011,12 +5011,11 @@ TclEvalEx( /* * TIP #280 Initialize tracking. Do not push on the frame stack yet. * - * We may continue counting based on a specific context (CTX), or open a - * new context, either for a sourced script, or 'eval'. For sourced files - * we always have a path object, even if nothing was specified in the - * interp itself. That makes code using it simpler as NULL checks can be - * left out. Sourced file without path in the 'scriptFile' is possible - * during Tcl initialization. + * We open a new context, either for a sourced script, or 'eval'. + * For sourced files we always have a path object, even if nothing was + * specified in the interp itself. That makes code using it simpler as + * NULL checks can be left out. Sourced file without path in the + * 'scriptFile' is possible during Tcl initialization. */ eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; @@ -5027,15 +5026,7 @@ TclEvalEx( eeFramePtr->line = NULL; iPtr->cmdFramePtr = eeFramePtr; - if (iPtr->evalFlags & TCL_EVAL_CTX) { - /* - * Path information comes out of the context. - */ - - eeFramePtr->type = TCL_LOCATION_SOURCE; - eeFramePtr->data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; - Tcl_IncrRefCount(eeFramePtr->data.eval.path); - } else if (iPtr->evalFlags & TCL_EVAL_FILE) { + if (iPtr->evalFlags & TCL_EVAL_FILE) { /* * Set up for a sourced file. */ @@ -6076,14 +6067,6 @@ TclNREvalObjEx( * We're not supposed to use the compiler or byte-code * interpreter. Let Tcl_EvalEx evaluate the command directly (and * probably more slowly). - * - * TIP #280. Propagate context as much as we can. Especially if the - * script to evaluate is a single literal it makes sense to look if - * our context is one with absolute line numbers we can then track - * into the literal itself too. - * - * See also tclCompile.c, TclInitCompileEnv, for the equivalent code - * in the bytecode compiler. */ const char *script; @@ -6104,6 +6087,8 @@ TclNREvalObjEx( * Another important action is to save (and later restore) the * continuation line information of the caller, in case we are * executing nested commands in the eval/direct path. + * + * TODO: Get test coverage in here. */ ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; @@ -6119,71 +6104,11 @@ TclNREvalObjEx( } Tcl_IncrRefCount(objPtr); - if (invoker == NULL) { - /* - * No context, force opening of our own. - */ - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { - /* - * We have an invoker, describing the command asking for the - * evaluation of a subordinate script. This script may originate - * in a literal word, or from a variable, etc. Using the line - * array we now check if we have good line information for the - * relevant word. The type of context is relevant as well. In a - * non-'source' context we don't have to try tracking lines. - * - * First see if the word exists and is a literal. If not we go - * through the easy dynamic branch. No need to perform more - * complex invokations. - */ + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - int pc = 0; - CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); - - *ctxPtr = *invoker; - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctxPtr->data.eval.path is not used. - * ctxPtr->data.tebc.codePtr is used instead. - */ - - TclGetSrcInfoForPc(ctxPtr); - pc = 1; - } - - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - - if ((invoker->nline <= word) || - (invoker->line[word] < 0) || - (ctxPtr->type != TCL_LOCATION_SOURCE)) { - /* - * Dynamic script, or dynamic context, force our own context. - */ - - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { - /* - * Absolute context to reuse. - */ - - iPtr->invokeCmdFramePtr = ctxPtr; - iPtr->evalFlags |= TCL_EVAL_CTX; - - result = TclEvalEx(interp, script, numSrcBytes, flags, - ctxPtr->line[word], NULL, script); - } - if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { - /* - * Death of SrcInfo reference. - */ - - Tcl_DecrRefCount(ctxPtr->data.eval.path); - } - TclStackFree(interp, ctxPtr); - } + TclDecrRefCount(objPtr); /* * Now release the lock on the continuation line information, if any, @@ -6194,7 +6119,6 @@ TclNREvalObjEx( Tcl_Release(iPtr->scriptCLLocPtr); } iPtr->scriptCLLocPtr = saveCLLocPtr; - TclDecrRefCount(objPtr); return result; } } diff --git a/generic/tclInt.h b/generic/tclInt.h index cd4ab7d..99f1305 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2201,7 +2201,6 @@ typedef struct Interp { #define TCL_ALLOW_EXCEPTIONS 4 #define TCL_EVAL_FILE 2 -#define TCL_EVAL_CTX 8 /* * Flag bits for Interp structures: -- cgit v0.12 From 47750cf97411377b0562db3816394c12707d8590 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Aug 2013 12:44:42 +0000 Subject: Add comment stating new limitation on Tcl(NR)EvalObjEx() interface. --- generic/tclBasic.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 00ae24e..8ba3825 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5893,6 +5893,11 @@ Tcl_GlobalEvalObj( * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is * specified. * + * If the flag TCL_EVAL_DIRECT is passed in, the value of invoker + * must be NULL. Support for non-NULL invokers in that mode has + * been removed since it was unused and untested. Failure to + * follow this limitation will lead to an assertion panic. + * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and the interpreter's result contains a value to supplement -- cgit v0.12 From 9923dc2908c517db587b6cbb398398ab3e45ec16 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Aug 2013 14:41:46 +0000 Subject: Replace potentially memleak creating safety check of a "cannot happen" condition with an assertion. --- generic/tclParse.c | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index 6723d39..c5cb1d1 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -13,6 +13,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include #include "tclInt.h" #include "tclParse.h" @@ -1578,16 +1579,13 @@ Tcl_ParseVar( * At this point we should have an object containing the value of a * variable. Just return the string from that object. * - * This should have returned the object for the user to manage, but - * instead we have some weak reference to the string value in the object, - * which is why we make sure the object exists after resetting the result. - * This isn't ideal, but it's the best we can do with the current - * documented interface. -- hobbs + * Since TclSubstTokens above returned TCL_OK, we know that objPtr + * is shared. It is in both the interp result and the value of the + * variable. Returning the string relies on that to be true. */ - if (!Tcl_IsShared(objPtr)) { - Tcl_IncrRefCount(objPtr); - } + assert( Tcl_IsShared(objPtr) ); + Tcl_ResetResult(interp); return TclGetString(objPtr); } -- cgit v0.12 From fd31090a583e76ccb81747a37f56e865669aebae Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Aug 2013 16:01:53 +0000 Subject: Test for TclContinuationsGet() usage, and simplifications. --- generic/tclBasic.c | 18 +----------------- tests/parse.test | 6 ++++++ 2 files changed, 7 insertions(+), 17 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8ba3825..7110025 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6092,21 +6092,13 @@ TclNREvalObjEx( * Another important action is to save (and later restore) the * continuation line information of the caller, in case we are * executing nested commands in the eval/direct path. - * - * TODO: Get test coverage in here. */ ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; - ContLineLoc *clLocPtr = TclContinuationsGet(objPtr); assert(invoker == NULL); - if (clLocPtr) { - iPtr->scriptCLLocPtr = clLocPtr; - Tcl_Preserve(iPtr->scriptCLLocPtr); - } else { - iPtr->scriptCLLocPtr = NULL; - } + iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); Tcl_IncrRefCount(objPtr); @@ -6115,14 +6107,6 @@ TclNREvalObjEx( TclDecrRefCount(objPtr); - /* - * Now release the lock on the continuation line information, if any, - * and restore the caller's settings. - */ - - if (iPtr->scriptCLLocPtr) { - Tcl_Release(iPtr->scriptCLLocPtr); - } iPtr->scriptCLLocPtr = saveCLLocPtr; return result; } diff --git a/tests/parse.test b/tests/parse.test index 9f2d50b..01443c9 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -1118,6 +1118,12 @@ test parse-21.0 {Bug 1884496} testevent { testevent queue a head $::script vwait done } {} +test parse-21.1 {TCL_EVAL_DIRECT coverage} testevent { + testevent queue a head {testevent delete a; \ + set ::done [dict get [info frame 0] line]} + vwait done + set ::done +} 2 cleanupTests } -- cgit v0.12 From 77c1bfb88bf69b0a55d43eca6a0029d82458a377 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Aug 2013 16:44:03 +0000 Subject: Remove Tcl_Preserve support for ContLineLoc values. It's not needed. This allows the clLoc field of CompileEnv struct to go away too. --- generic/tclCompile.c | 19 ++----------------- generic/tclCompile.h | 4 ---- generic/tclObj.c | 38 +++----------------------------------- 3 files changed, 5 insertions(+), 56 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 618b6fa..f5c8d41 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -713,9 +713,7 @@ TclSetByteCodeFromAny( clLocPtr = TclContinuationsGet(objPtr); if (clLocPtr) { - compEnv.clLoc = clLocPtr; - compEnv.clNext = &compEnv.clLoc->loc[0]; - Tcl_Preserve(compEnv.clLoc); + compEnv.clNext = &clLocPtr->loc[0]; } TclCompileScript(interp, stringPtr, length, &compEnv); @@ -742,9 +740,7 @@ TclSetByteCodeFromAny( TclInitCompileEnv(interp, &compEnv, stringPtr, length, iPtr->invokeCmdFramePtr, iPtr->invokeWord); if (clLocPtr) { - compEnv.clLoc = clLocPtr; - compEnv.clNext = &compEnv.clLoc->loc[0]; - Tcl_Preserve(compEnv.clLoc); + compEnv.clNext = &clLocPtr->loc[0]; } compEnv.atCmdStart = 2; /* The disabling magic. */ TclCompileScript(interp, stringPtr, length, &compEnv); @@ -1489,7 +1485,6 @@ TclInitCompileEnv( * data is available. */ - envPtr->clLoc = NULL; envPtr->clNext = NULL; envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; @@ -1574,16 +1569,6 @@ TclFreeCompileEnv( ReleaseCmdWordData(envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; } - - /* - * If we used data about invisible continuation lines, then now is the - * time to release on our hold on it. The lock was set in function - * TclSetByteCodeFromAny(), found in this file. - */ - - if (envPtr->clLoc) { - Tcl_Release(envPtr->clLoc); - } } /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index beb28fd..5660055 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -365,10 +365,6 @@ typedef struct CompileEnv { * encountered that have not yet been paired * with a corresponding * INST_INVOKE_EXPANDED. */ - ContLineLoc *clLoc; /* If not NULL, the table holding the - * locations of the invisible continuation - * lines in the input script, to adjust the - * line counter. */ int *clNext; /* If not NULL, it refers to the next slot in * clLoc to check for an invisible * continuation line. */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 542d6d1..930e1fd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -97,7 +97,6 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; -static void ContLineLocFree(char *clientData); static void TclThreadFinalizeContLines(ClientData clientData); static ThreadSpecificData *TclGetContLineTable(void); @@ -805,14 +804,7 @@ TclThreadFinalizeContLines( for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - /* - * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because - * here we can be sure that the compiler will not hold references to - * the data in the hashtable, and using TEF might bork the - * finalization sequence. - */ - - ContLineLocFree(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(tsdPtr->lineCLPtr); @@ -821,30 +813,6 @@ TclThreadFinalizeContLines( } /* - *---------------------------------------------------------------------- - * - * ContLineLocFree -- - * - * The freProc for continuation line location tables. - * - * Results: - * None. - * - * Side effects: - * Releases memory. - * - * TIP #280 - *---------------------------------------------------------------------- - */ - -static void -ContLineLocFree( - char *clientData) -{ - ckfree(clientData); -} - -/* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- @@ -1405,7 +1373,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } @@ -1496,7 +1464,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } -- cgit v0.12 From 4536322b256c1539a134ea7ecc4a7c32e7b05451 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Aug 2013 19:45:13 +0000 Subject: Give (objc, objv) their own ride from enter to leave traces. --- generic/tclBasic.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 7110025..067da63 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4727,7 +4727,7 @@ TEOV_RunEnterTraces( */ TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), - commandPtr, cmdPtr, NULL); + commandPtr, cmdPtr, Tcl_NewListObj(objc, objv)); cmdPtr->refCount++; } else { Tcl_DecrRefCount(commandPtr); @@ -4748,11 +4748,10 @@ TEOV_RunLeaveTraces( int traceCode = PTR2INT(data[0]); Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; + Tcl_Obj *wordsPtr = data[3]; command = Tcl_GetStringFromObj(commandPtr, &length); - if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) { - Tcl_Panic("Who messed with commandPtr?"); - } + Tcl_ListObjGetElements(NULL, wordsPtr, &objc, &objv); if (!(cmdPtr->flags & CMD_IS_DELETED)) { if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ @@ -4765,6 +4764,7 @@ TEOV_RunLeaveTraces( } } Tcl_DecrRefCount(commandPtr); + Tcl_DecrRefCount(wordsPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. -- cgit v0.12 From dddbd100aedbc995c1a203715479978f79e82ba6 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 7 Aug 2013 20:27:30 +0000 Subject: Revise GetCommandSource() to return a normal Tcl_Obj value. --- generic/tclBasic.c | 26 ++++++++------------------ 1 file changed, 8 insertions(+), 18 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 067da63..6542726 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3358,15 +3358,6 @@ CancelEvalProc( * This function returns a Tcl_Obj with the full source string for the * command. This insures that traces get a correct NUL-terminated command * string. The Tcl_Obj has refCount==1. - * - * *** MAINTAINER WARNING *** - * The returned Tcl_Obj is all wrong for any purpose but getting the - * source string for an objc/objv command line in the stringRep (no - * stringRep if no source is available) and the corresponding substituted - * version in the List intrep. - * This means that the intRep and stringRep DO NOT COINCIDE! Using these - * Tcl_Objs normally is likely to break things. - * *---------------------------------------------------------------------- */ @@ -3376,13 +3367,13 @@ GetCommandSource( int objc, Tcl_Obj *const objv[]) { - Tcl_Obj *objPtr, *obj2Ptr; + Tcl_Obj *objPtr = NULL; CmdFrame *cfPtr = iPtr->cmdFramePtr; - const char *command = NULL; - int numChars; - objPtr = Tcl_NewListObj(objc, objv); if (cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) { + const char *command = NULL; + int numChars; + switch (cfPtr->type) { case TCL_LOCATION_EVAL: case TCL_LOCATION_SOURCE: @@ -3395,13 +3386,12 @@ GetCommandSource( break; } if (command) { - obj2Ptr = Tcl_NewStringObj(command, numChars); - objPtr->bytes = obj2Ptr->bytes; - objPtr->length = numChars; - obj2Ptr->bytes = NULL; - Tcl_DecrRefCount(obj2Ptr); + objPtr = Tcl_NewStringObj(command, numChars); } } + if (objPtr == NULL) { + objPtr = Tcl_NewListObj(objc, objv); + } Tcl_IncrRefCount(objPtr); return objPtr; } -- cgit v0.12 From fec32bb50c597bfbb21ad55211339355034f6d55 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 9 Aug 2013 16:48:30 +0000 Subject: Revised GetCommandSource() can (and thus should) return a normal zero refcount value. --- generic/tclBasic.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6542726..9755a21 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3357,7 +3357,7 @@ CancelEvalProc( * * This function returns a Tcl_Obj with the full source string for the * command. This insures that traces get a correct NUL-terminated command - * string. The Tcl_Obj has refCount==1. + * string. *---------------------------------------------------------------------- */ @@ -3392,7 +3392,6 @@ GetCommandSource( if (objPtr == NULL) { objPtr = Tcl_NewListObj(objc, objv); } - Tcl_IncrRefCount(objPtr); return objPtr; } -- cgit v0.12 From de857ca207e4dceea586bf2dbfe497df4d9d02c8 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 10 Aug 2013 05:16:38 +0000 Subject: Arrange for both execution traces and [info frame] to get their pre-subst source strings from a common routine, with care taken to reduce copying by that routine. --- generic/tclBasic.c | 41 +++++++++++++++-------------------------- generic/tclCmdIL.c | 25 ++++++++++++++++++++++--- generic/tclExecute.c | 19 +++++++++++++++++-- generic/tclInt.h | 5 +++++ 4 files changed, 59 insertions(+), 31 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9755a21..1cd2eae 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3367,32 +3367,12 @@ GetCommandSource( int objc, Tcl_Obj *const objv[]) { - Tcl_Obj *objPtr = NULL; CmdFrame *cfPtr = iPtr->cmdFramePtr; - if (cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) { - const char *command = NULL; - int numChars; - - switch (cfPtr->type) { - case TCL_LOCATION_EVAL: - case TCL_LOCATION_SOURCE: - command = cfPtr->cmd; - numChars = cfPtr->len; - break; - case TCL_LOCATION_BC: - case TCL_LOCATION_PREBC: - command = TclGetSrcInfoForCmd(iPtr, &numChars); - break; - } - if (command) { - objPtr = Tcl_NewStringObj(command, numChars); - } + if (cfPtr && (cfPtr->numLevels != iPtr->numLevels-1)) { + cfPtr = NULL; } - if (objPtr == NULL) { - objPtr = Tcl_NewListObj(objc, objv); - } - return objPtr; + return TclGetSourceFromFrame(cfPtr, objc, objv); } /* @@ -4678,6 +4658,7 @@ TEOV_RunEnterTraces( Tcl_Obj *commandPtr; commandPtr = GetCommandSource(iPtr, objc, objv); + Tcl_IncrRefCount(commandPtr); command = Tcl_GetStringFromObj(commandPtr, &length); /* @@ -5013,6 +4994,7 @@ TclEvalEx( eeFramePtr->nextPtr = iPtr->cmdFramePtr; eeFramePtr->nline = 0; eeFramePtr->line = NULL; + eeFramePtr->cmdObj = NULL; iPtr->cmdFramePtr = eeFramePtr; if (iPtr->evalFlags & TCL_EVAL_FILE) { @@ -5243,6 +5225,10 @@ TclEvalEx( eeFramePtr->line = NULL; eeFramePtr->nline = 0; + if (eeFramePtr->cmdObj) { + Tcl_DecrRefCount(eeFramePtr->cmdObj); + eeFramePtr->cmdObj = NULL; + } if (code != TCL_OK) { goto error; @@ -5983,7 +5969,6 @@ TclNREvalObjEx( Tcl_IncrRefCount(objPtr); listPtr = TclListObjCopy(interp, objPtr); Tcl_IncrRefCount(listPtr); - TclDecrRefCount(objPtr); if (word != INT_MIN) { /* @@ -6013,7 +5998,9 @@ TclNREvalObjEx( eoFramePtr->framePtr = iPtr->framePtr; eoFramePtr->nextPtr = iPtr->cmdFramePtr; - eoFramePtr->cmd = Tcl_GetStringFromObj(listPtr, &(eoFramePtr->len)); + eoFramePtr->cmdObj = objPtr; + eoFramePtr->cmd = NULL; + eoFramePtr->len = 0; eoFramePtr->data.eval.path = NULL; iPtr->cmdFramePtr = eoFramePtr; @@ -6021,7 +6008,7 @@ TclNREvalObjEx( TclMarkTailcall(interp); TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, - NULL, NULL); + objPtr, NULL); ListObjGetElements(listPtr, objc, objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); @@ -6156,6 +6143,7 @@ TEOEx_ListCallback( Interp *iPtr = (Interp *) interp; Tcl_Obj *listPtr = data[0]; CmdFrame *eoFramePtr = data[1]; + Tcl_Obj *objPtr = data[2]; /* * Remove the cmdFrame @@ -6165,6 +6153,7 @@ TEOEx_ListCallback( iPtr->cmdFramePtr = eoFramePtr->nextPtr; TclStackFree(interp, eoFramePtr); } + TclDecrRefCount(objPtr); TclDecrRefCount(listPtr); return result; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 180d814..da9edd6 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1266,6 +1266,25 @@ InfoFrameCmd( */ Tcl_Obj * +TclGetSourceFromFrame( + CmdFrame *cfPtr, + int objc, + Tcl_Obj *const objv[]) +{ + if (cfPtr == NULL) { + return Tcl_NewListObj(objc, objv); + } + if (cfPtr->cmdObj == NULL) { + if (cfPtr->cmd == NULL) { + cfPtr->cmd = TclGetSrcInfoForCmdFrame(cfPtr, &cfPtr->len); + } + cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); + Tcl_IncrRefCount(cfPtr->cmdObj); + } + return cfPtr->cmdObj; +} + +Tcl_Obj * TclInfoFrame( Tcl_Interp *interp, /* Current interpreter. */ CmdFrame *framePtr) /* Frame to get info for. */ @@ -1307,7 +1326,7 @@ TclInfoFrame( } else { ADD_PAIR("line", Tcl_NewIntObj(1)); } - ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd, framePtr->len)); + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); break; case TCL_LOCATION_PREBC: @@ -1355,7 +1374,7 @@ TclInfoFrame( Tcl_DecrRefCount(fPtr->data.eval.path); } - ADD_PAIR("cmd", Tcl_NewStringObj(fPtr->cmd, fPtr->len)); + ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); TclStackFree(interp, fPtr); break; } @@ -1374,7 +1393,7 @@ TclInfoFrame( * the result list object. */ - ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd, framePtr->len)); + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); break; case TCL_LOCATION_PROC: diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f6072a1..d8ccf40 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2006,6 +2006,7 @@ TclNRExecuteByteCode( bcFramePtr->litarg = NULL; bcFramePtr->data.tebc.codePtr = codePtr; bcFramePtr->data.tebc.pc = NULL; + bcFramePtr->cmdObj = NULL; bcFramePtr->cmd = NULL; bcFramePtr->len = 0; @@ -2130,6 +2131,11 @@ TEBCresume( result = TCL_ERROR; } NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); + if (bcFramePtr->cmdObj) { + Tcl_DecrRefCount(bcFramePtr->cmdObj); + bcFramePtr->cmdObj = NULL; + bcFramePtr->cmd = NULL; + } iPtr->cmdFramePtr = bcFramePtr->nextPtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); @@ -8761,7 +8767,14 @@ TclGetSrcInfoForCmd( Interp *iPtr, int *lenPtr) { - CmdFrame *cfPtr = iPtr->cmdFramePtr; + return TclGetSrcInfoForCmdFrame(iPtr->cmdFramePtr, lenPtr); +} + +const char * +TclGetSrcInfoForCmdFrame( + CmdFrame *cfPtr, + int *lenPtr) +{ ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, @@ -8775,11 +8788,13 @@ TclGetSrcInfoForPc( ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; assert(cfPtr->type == TCL_LOCATION_BC); - assert(cfPtr->cmd == NULL); + + if (cfPtr->cmd == NULL) { cfPtr->cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); + } assert(cfPtr->cmd != NULL); { diff --git a/generic/tclInt.h b/generic/tclInt.h index 99f1305..161d166 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1208,6 +1208,7 @@ typedef struct CmdFrame { const char *pc; /* ... and instruction pointer. */ } tebc; } data; + Tcl_Obj *cmdObj; const char *cmd; /* The executed command, if possible... */ int len; /* ... and its length. */ int numLevels; /* Value of interp's numLevels when the frame @@ -2907,7 +2908,11 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); +MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr); +MODULE_SCOPE const char *TclGetSrcInfoForCmdFrame(CmdFrame *cfPtr, + int *lenPtr); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); -- cgit v0.12 From 420294d3ed2faf23f5b57ed32e1bf869c4f71b8f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 11 Aug 2013 14:41:10 +0000 Subject: Never guess non-existing timezone name "America/Brasilia" on Windows. Reported by Arnulf Wiedemann --- library/clock.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/clock.tcl b/library/clock.tcl index 49aad23..1f83716 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -325,7 +325,7 @@ proc ::tcl::clock::Initialize {} { {-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo {-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab {-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires - {-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Brasilia + {-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia {-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo {-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha {-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores -- cgit v0.12 From 9d7666659bb7ba5dcf54394bb4c2a555b2f46f7c Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 12 Aug 2013 20:00:14 +0000 Subject: Use a new flag value TCL_EVAL_SOURCE_IN_FRAME passed in by callers to determine whether the pre-subst source information in a CmdFrame is to be used. This takes the place of numLevels cross checking, so that field is removed. Routines are consolidated as well. --- generic/tclBasic.c | 43 +++++++++---------------------------------- generic/tclExecute.c | 13 ++----------- generic/tclInt.h | 8 +++----- 3 files changed, 14 insertions(+), 50 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1cd2eae..b6c6f38 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -127,8 +127,6 @@ static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; -static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, - Tcl_Obj *const objv[]); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; @@ -149,7 +147,7 @@ static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, - Command **cmdPtrPtr, int objc, + Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; @@ -3353,31 +3351,6 @@ CancelEvalProc( /* *---------------------------------------------------------------------- * - * GetCommandSource -- - * - * This function returns a Tcl_Obj with the full source string for the - * command. This insures that traces get a correct NUL-terminated command - * string. - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -GetCommandSource( - Interp *iPtr, - int objc, - Tcl_Obj *const objv[]) -{ - CmdFrame *cfPtr = iPtr->cmdFramePtr; - - if (cfPtr && (cfPtr->numLevels != iPtr->numLevels-1)) { - cfPtr = NULL; - } - return TclGetSourceFromFrame(cfPtr, objc, objv); -} - -/* - *---------------------------------------------------------------------- - * * TclCleanupCommand -- * * This function frees up a Command structure unless it is still @@ -4230,7 +4203,9 @@ TclNREvalObjv( * necessary. */ - result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr); + result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv), objc, objv, lookupNsPtr); if (!cmdPtr) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } @@ -4644,6 +4619,7 @@ static int TEOV_RunEnterTraces( Tcl_Interp *interp, Command **cmdPtrPtr, + Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr) @@ -4655,9 +4631,7 @@ TEOV_RunEnterTraces( int newEpoch; const char *command; int length; - Tcl_Obj *commandPtr; - commandPtr = GetCommandSource(iPtr, objc, objv); Tcl_IncrRefCount(commandPtr); command = Tcl_GetStringFromObj(commandPtr, &length); @@ -4989,7 +4963,6 @@ TclEvalEx( */ eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; - eeFramePtr->numLevels = iPtr->numLevels; eeFramePtr->framePtr = iPtr->framePtr; eeFramePtr->nextPtr = iPtr->cmdFramePtr; eeFramePtr->nline = 0; @@ -5220,7 +5193,8 @@ TclEvalEx( eeFramePtr->line = lines; TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); - code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR); + code = Tcl_EvalObjv(interp, objectsUsed, objv, + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME); TclArgumentRelease(interp, objv, objectsUsed); eeFramePtr->line = NULL; @@ -5994,7 +5968,6 @@ TclNREvalObjEx( eoFramePtr->type = TCL_LOCATION_EVAL; eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->numLevels = iPtr->numLevels; eoFramePtr->framePtr = iPtr->framePtr; eoFramePtr->nextPtr = iPtr->cmdFramePtr; @@ -6004,6 +5977,8 @@ TclNREvalObjEx( eoFramePtr->data.eval.path = NULL; iPtr->cmdFramePtr = eoFramePtr; + + flags |= TCL_EVAL_SOURCE_IN_FRAME; } TclMarkTailcall(interp); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d8ccf40..58e4d3d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1998,7 +1998,6 @@ TclNRExecuteByteCode( bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); - bcFramePtr->numLevels = iPtr->numLevels; bcFramePtr->framePtr = iPtr->framePtr; bcFramePtr->nextPtr = iPtr->cmdFramePtr; bcFramePtr->nline = 0; @@ -2906,7 +2905,7 @@ TEBCresume( pc += pcAdjustment; TEBC_YIELD(); return TclNREvalObjv(interp, objc, objv, - TCL_EVAL_NOERR, NULL); + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); #if TCL_SUPPORT_84_BYTECODE case INST_CALL_BUILTIN_FUNC1: @@ -8741,7 +8740,7 @@ IllegalExprOperandType( /* *---------------------------------------------------------------------- * - * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd -- + * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmdFrame -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about @@ -8763,14 +8762,6 @@ IllegalExprOperandType( */ const char * -TclGetSrcInfoForCmd( - Interp *iPtr, - int *lenPtr) -{ - return TclGetSrcInfoForCmdFrame(iPtr->cmdFramePtr, lenPtr); -} - -const char * TclGetSrcInfoForCmdFrame( CmdFrame *cfPtr, int *lenPtr) diff --git a/generic/tclInt.h b/generic/tclInt.h index 161d166..19cd883 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1211,8 +1211,6 @@ typedef struct CmdFrame { Tcl_Obj *cmdObj; const char *cmd; /* The executed command, if possible... */ int len; /* ... and its length. */ - int numLevels; /* Value of interp's numLevels when the frame - * was pushed. */ const struct CFWordBC *litarg; /* Link to set of literal arguments which have * ben pushed on the lineLABCPtr stack by @@ -2200,8 +2198,9 @@ typedef struct Interp { * other than these should be turned into errors. */ -#define TCL_ALLOW_EXCEPTIONS 4 -#define TCL_EVAL_FILE 2 +#define TCL_ALLOW_EXCEPTIONS 0x04 +#define TCL_EVAL_FILE 0x02 +#define TCL_EVAL_SOURCE_IN_FRAME 0x10 /* * Flag bits for Interp structures: @@ -2910,7 +2909,6 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr); MODULE_SCOPE const char *TclGetSrcInfoForCmdFrame(CmdFrame *cfPtr, int *lenPtr); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, -- cgit v0.12 From 18859d2c2c1b21c3661e1137c93a9ad27ddf10b7 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Aug 2013 19:26:35 +0000 Subject: [0aa8f12dcc] Restore minimum code to stop failing tests. --- generic/tclExecute.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2cdba8a..94ee3af 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5547,6 +5547,11 @@ TEBCresume( w1 = (Tcl_WideInt) l1; w2 = (Tcl_WideInt) l2; wResult = w1 - w2; +#ifdef TCL_WIDE_INT_IS_LONG + if (Overflowing(w1, ~w2, wResult)) { + goto overflow; + } +#endif wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { @@ -7910,7 +7915,9 @@ ExecuteExtendedBinaryMathOp( case INST_SUB: wResult = w1 - w2; +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif { /* * Must check for overflow. The macro tests for overflows -- cgit v0.12 From 9c15217967a7614ac17d324144b8e39d788b6eef Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 14 Aug 2013 04:13:21 +0000 Subject: Only schedule leave traces if enter traces complete successfully. This avoids a memleak, and opens a data slot, so we can pass objc, objv without the need to copy them into a list value. --- generic/tclBasic.c | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b6c6f38..f852b44 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4665,13 +4665,13 @@ TEOV_RunEnterTraces( *cmdPtrPtr = cmdPtr; } - if (cmdPtr) { + if (cmdPtr && (traceCode == TCL_OK)) { /* * Command was found: push a record to schedule the leave traces. */ - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), - commandPtr, cmdPtr, Tcl_NewListObj(objc, objv)); + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); cmdPtr->refCount++; } else { Tcl_DecrRefCount(commandPtr); @@ -4686,19 +4686,18 @@ TEOV_RunLeaveTraces( int result) { Interp *iPtr = (Interp *) interp; - const char *command; - int length, objc; - Tcl_Obj **objv; - int traceCode = PTR2INT(data[0]); + int traceCode = TCL_OK; + int objc = PTR2INT(data[0]); Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; - Tcl_Obj *wordsPtr = data[3]; + Tcl_Obj **objv = data[3]; - command = Tcl_GetStringFromObj(commandPtr, &length); - Tcl_ListObjGetElements(NULL, wordsPtr, &objc, &objv); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ + int length; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); + + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } @@ -4708,7 +4707,6 @@ TEOV_RunLeaveTraces( } } Tcl_DecrRefCount(commandPtr); - Tcl_DecrRefCount(wordsPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. -- cgit v0.12 From b2d7315f923bd7c0eae390595466fcf0ff1388ac Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 14 Aug 2013 12:15:59 +0000 Subject: Consolidate some helper routines. --- generic/tclCmdIL.c | 19 ------------------- generic/tclExecute.c | 27 +++++++++++++++++++-------- generic/tclInt.h | 2 -- 3 files changed, 19 insertions(+), 29 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index da9edd6..fa4ead4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1266,25 +1266,6 @@ InfoFrameCmd( */ Tcl_Obj * -TclGetSourceFromFrame( - CmdFrame *cfPtr, - int objc, - Tcl_Obj *const objv[]) -{ - if (cfPtr == NULL) { - return Tcl_NewListObj(objc, objv); - } - if (cfPtr->cmdObj == NULL) { - if (cfPtr->cmd == NULL) { - cfPtr->cmd = TclGetSrcInfoForCmdFrame(cfPtr, &cfPtr->len); - } - cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); - Tcl_IncrRefCount(cfPtr->cmdObj); - } - return cfPtr->cmdObj; -} - -Tcl_Obj * TclInfoFrame( Tcl_Interp *interp, /* Current interpreter. */ CmdFrame *framePtr) /* Frame to get info for. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 58e4d3d..d066476 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8740,7 +8740,7 @@ IllegalExprOperandType( /* *---------------------------------------------------------------------- * - * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmdFrame -- + * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about @@ -8761,15 +8761,26 @@ IllegalExprOperandType( *---------------------------------------------------------------------- */ -const char * -TclGetSrcInfoForCmdFrame( +Tcl_Obj * +TclGetSourceFromFrame( CmdFrame *cfPtr, - int *lenPtr) + int objc, + Tcl_Obj *const objv[]) { - ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - - return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr, NULL, NULL); + if (cfPtr == NULL) { + return Tcl_NewListObj(objc, objv); + } + if (cfPtr->cmdObj == NULL) { + if (cfPtr->cmd == NULL) { + ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; + + cfPtr->cmd = GetSrcInfoForPc((unsigned char *) + cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); + } + cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); + Tcl_IncrRefCount(cfPtr->cmdObj); + } + return cfPtr->cmdObj; } void diff --git a/generic/tclInt.h b/generic/tclInt.h index 19cd883..6056119 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2909,8 +2909,6 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE const char *TclGetSrcInfoForCmdFrame(CmdFrame *cfPtr, - int *lenPtr); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); -- cgit v0.12 From cb022ef5bd73c2dcf81758815c2b7812e33cb7f5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 14 Aug 2013 14:15:36 +0000 Subject: restore all #ifdef TCL_WIDE_INT_IS_LONG, which were accidently removed in [19ff9b95e1] --- generic/tclBasic.c | 2 ++ generic/tclCmdMZ.c | 4 +++ generic/tclExecute.c | 87 +++++++++++++++++++++++++++++++++++++++++++++++--- generic/tclIOUtil.c | 2 ++ generic/tclInt.h | 4 +++ generic/tclObj.c | 35 ++++++++++++++++++++ generic/tclProc.c | 2 ++ generic/tclStrToD.c | 4 +++ generic/tclStringObj.c | 2 ++ generic/tclTimer.c | 6 ++++ 10 files changed, 144 insertions(+), 4 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index bb175d3..fac22c3 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6799,6 +6799,7 @@ ExprAbsFunc( return TCL_OK; } +#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { Tcl_WideInt w = *((const Tcl_WideInt *) ptr); @@ -6812,6 +6813,7 @@ ExprAbsFunc( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); return TCL_OK; } +#endif if (type == TCL_NUMBER_BIG) { if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 40cd940..5d1820c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1565,7 +1565,9 @@ StringIsCmd( /* TODO */ if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType) || +#ifndef TCL_WIDE_INT_IS_LONG (objPtr->typePtr == &tclWideIntType) || +#endif (objPtr->typePtr == &tclBignumType)) { break; } @@ -1600,7 +1602,9 @@ StringIsCmd( goto failedIntParse; case STR_IS_ENTIER: if ((objPtr->typePtr == &tclIntType) || +#ifndef TCL_WIDE_INT_IS_LONG (objPtr->typePtr == &tclWideIntType) || +#endif (objPtr->typePtr == &tclBignumType)) { break; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 94ee3af..f3d5b59 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -380,6 +380,23 @@ VarHashCreateVar( * ClientData *ptrPtr, int *tPtr); */ +#ifdef TCL_WIDE_INT_IS_LONG +#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(tPtr) = TCL_NUMBER_LONG, \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.longValue)), TCL_OK) : \ + ((objPtr)->typePtr == &tclDoubleType) \ + ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ + ? (*(tPtr) = TCL_NUMBER_NAN) \ + : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ + ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ + (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ + ? TCL_ERROR : \ + TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) +#else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ @@ -399,6 +416,7 @@ VarHashCreateVar( (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ ? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) +#endif /* TCL_WIDE_INT_IS_LONG */ /* * Macro used in this file to save a function call for common uses of @@ -422,6 +440,13 @@ VarHashCreateVar( * Tcl_WideInt *wideIntPtr); */ +#ifdef TCL_WIDE_INT_IS_LONG +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#else /* !TCL_WIDE_INT_IS_LONG */ #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclWideIntType) \ ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ @@ -429,6 +454,7 @@ VarHashCreateVar( ? (*(wideIntPtr) = (Tcl_WideInt) \ ((objPtr)->internalRep.longValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#endif /* TCL_WIDE_INT_IS_LONG */ /* * Macro used to make the check for type overflow more mnemonic. This works by @@ -1784,6 +1810,7 @@ TclIncrObj( TclSetLongObj(valuePtr, sum); return TCL_OK; } +#ifndef TCL_WIDE_INT_IS_LONG { Tcl_WideInt w1 = (Tcl_WideInt) augend; Tcl_WideInt w2 = (Tcl_WideInt) addend; @@ -1796,6 +1823,7 @@ TclIncrObj( TclSetWideIntObj(valuePtr, w1 + w2); return TCL_OK; } +#endif } if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { @@ -1815,6 +1843,7 @@ TclIncrObj( return TCL_ERROR; } +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; @@ -1831,6 +1860,7 @@ TclIncrObj( return TCL_OK; } } +#endif Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); @@ -3304,7 +3334,9 @@ TEBCresume( { Tcl_Obj *incrPtr; +#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; +#endif long increment; case INST_INCR_SCALAR1: @@ -3424,6 +3456,7 @@ TEBCresume( } goto doneIncr; } +#ifndef TCL_WIDE_INT_IS_LONG w = (Tcl_WideInt)augend; TRACE(("%u %ld => ", opnd, increment)); @@ -3443,7 +3476,9 @@ TEBCresume( TclSetWideIntObj(objPtr, w+increment); } goto doneIncr; +#endif } /* end if (type == TCL_NUMBER_LONG) */ +#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { Tcl_WideInt sum; @@ -3475,6 +3510,7 @@ TEBCresume( goto doneIncr; } } +#endif } if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared */ @@ -5541,6 +5577,15 @@ TEBCresume( w1 = (Tcl_WideInt) l1; w2 = (Tcl_WideInt) l2; wResult = w1 + w2; +#ifdef TCL_WIDE_INT_IS_LONG + /* + * Check for overflow. + */ + + if (Overflowing(w1, w2, wResult)) { + goto overflow; + } +#endif goto wideResultOfArithmetic; case INST_SUB: @@ -5548,9 +5593,9 @@ TEBCresume( w2 = (Tcl_WideInt) l2; wResult = w1 - w2; #ifdef TCL_WIDE_INT_IS_LONG - if (Overflowing(w1, ~w2, wResult)) { - goto overflow; - } + if (Overflowing(w1, ~w2, wResult)) { + goto overflow; + } #endif wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); @@ -7083,6 +7128,7 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } } +#ifndef TCL_WIDE_INT_IS_LONG if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *)ptr1); if (type2 != TCL_NUMBER_BIG) { @@ -7127,6 +7173,7 @@ ExecuteExtendedBinaryMathOp( mp_clear(&big2); return NULL; } +#endif Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); @@ -7156,9 +7203,11 @@ ExecuteExtendedBinaryMathOp( case TCL_NUMBER_LONG: invalid = (*((const long *)ptr2) < 0L); break; +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; +#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); invalid = (mp_cmp_d(&big2, 0) == MP_LT); @@ -7238,9 +7287,11 @@ ExecuteExtendedBinaryMathOp( case TCL_NUMBER_LONG: zero = (*(const long *)ptr1 > 0L); break; +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; +#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); zero = (mp_cmp_d(&big1, 0) == MP_GT); @@ -7257,6 +7308,7 @@ ExecuteExtendedBinaryMathOp( } shift = (int)(*(const long *)ptr2); +#ifndef TCL_WIDE_INT_IS_LONG /* * Handle shifts within the native wide range. */ @@ -7271,6 +7323,7 @@ ExecuteExtendedBinaryMathOp( } WIDE_RESULT(w1 >> shift); } +#endif } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -7438,6 +7491,7 @@ ExecuteExtendedBinaryMathOp( BIG_RESULT(&bigResult); } +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); @@ -7458,6 +7512,7 @@ ExecuteExtendedBinaryMathOp( } WIDE_RESULT(wResult); } +#endif l1 = *((const long *)ptr1); l2 = *((const long *)ptr2); @@ -7514,11 +7569,13 @@ ExecuteExtendedBinaryMathOp( negativeExponent = (l2 < 0); oddExponent = (int) (l2 & 1); break; +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); negativeExponent = (w2 < 0); oddExponent = (int) (w2 & (Tcl_WideInt)1); break; +#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); @@ -7608,9 +7665,11 @@ ExecuteExtendedBinaryMathOp( if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { LONG_RESULT(1L << l2); } +#if !defined(TCL_WIDE_INT_IS_LONG) if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { WIDE_RESULT(((Tcl_WideInt) 1) << l2); } +#endif goto overflowExpon; } if (l1 == -2) { @@ -7623,9 +7682,11 @@ ExecuteExtendedBinaryMathOp( if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { LONG_RESULT(signum * (1L << l2)); } +#if !defined(TCL_WIDE_INT_IS_LONG) if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); } +#endif goto overflowExpon; } #if (LONG_MAX == 0x7fffffff) @@ -7697,11 +7758,13 @@ ExecuteExtendedBinaryMathOp( } #endif } -#if (LONG_MAX > 0x7fffffff) +#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) if (type1 == TCL_NUMBER_LONG) { w1 = l1; +#ifndef TCL_WIDE_INT_IS_LONG } else if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); +#endif } else { goto overflowExpon; } @@ -7901,7 +7964,9 @@ ExecuteExtendedBinaryMathOp( switch (opcode) { case INST_ADD: wResult = w1 + w2; +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif { /* * Check for overflow. @@ -8041,10 +8106,12 @@ ExecuteExtendedUnaryMathOp( switch (opcode) { case INST_BITNOT: +#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); } +#endif Tcl_TakeBignumFromObj(NULL, valuePtr, &big); /* ~a = - a - 1 */ mp_neg(&big, &big); @@ -8061,6 +8128,7 @@ ExecuteExtendedUnaryMathOp( } TclBNInitBignumFromLong(&big, *(const long *) ptr); break; +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w = *((const Tcl_WideInt *) ptr); if (w != LLONG_MIN) { @@ -8068,6 +8136,7 @@ ExecuteExtendedUnaryMathOp( } TclBNInitBignumFromWideInt(&big, w); break; +#endif default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } @@ -8111,7 +8180,9 @@ TclCompareTwoNumbers( mp_int big1, big2; double d1, d2, tmp; long l1, l2; +#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w1, w2; +#endif (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); @@ -8124,10 +8195,12 @@ TclCompareTwoNumbers( l2 = *((const long *)ptr2); longCompare: return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); w1 = (Tcl_WideInt)l1; goto wideCompare; +#endif case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); d1 = (double) l1; @@ -8174,6 +8247,7 @@ TclCompareTwoNumbers( return compare; } +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w1 = *((const Tcl_WideInt *)ptr1); switch (type2) { @@ -8210,6 +8284,7 @@ TclCompareTwoNumbers( mp_clear(&big2); return compare; } +#endif case TCL_NUMBER_DOUBLE: d1 = *((const double *)ptr1); @@ -8233,6 +8308,7 @@ TclCompareTwoNumbers( } l1 = (long) d1; goto longCompare; +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; @@ -8248,6 +8324,7 @@ TclCompareTwoNumbers( } w1 = (Tcl_WideInt) d1; goto wideCompare; +#endif case TCL_NUMBER_BIG: if (TclIsInfinite(d1)) { return (d1 > 0.0) ? MP_GT : MP_LT; @@ -8275,7 +8352,9 @@ TclCompareTwoNumbers( case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: +#endif case TCL_NUMBER_LONG: compare = mp_cmp_d(&big1, 0); mp_clear(&big1); diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index adbfe07..a8dd484 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -267,6 +267,7 @@ Tcl_Stat( ret = Tcl_FSStat(pathPtr, &buf); Tcl_DecrRefCount(pathPtr); if (ret != -1) { +#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt tmp1, tmp2, tmp3 = 0; # define OUT_OF_RANGE(x) \ @@ -304,6 +305,7 @@ Tcl_Stat( # undef OUT_OF_RANGE # undef OUT_OF_URANGE +#endif /* !TCL_WIDE_INT_IS_LONG */ /* * Copy across all supported fields, with possible type coercions on diff --git a/generic/tclInt.h b/generic/tclInt.h index fa6af8e..060b4bc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2632,7 +2632,9 @@ MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclArraySearchType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; +#ifndef TCL_WIDE_INT_IS_LONG MODULE_SCOPE const Tcl_ObjType tclWideIntType; +#endif MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; @@ -4381,6 +4383,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * value of strings like: "yes", "no", "true", "false", "on", "off". */ +#ifndef TCL_WIDE_INT_IS_LONG #define TclSetWideIntObj(objPtr, w) \ do { \ TclInvalidateStringRep(objPtr); \ @@ -4388,6 +4391,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ (objPtr)->typePtr = &tclWideIntType; \ } while (0) +#endif #define TclSetDoubleObj(objPtr, d) \ do { \ diff --git a/generic/tclObj.c b/generic/tclObj.c index cd75d8d..224503d 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -212,8 +212,10 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); +#ifndef TCL_WIDE_INT_IS_LONG static void UpdateStringOfWideInt(Tcl_Obj *objPtr); static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +#endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void UpdateStringOfBignum(Tcl_Obj *objPtr); @@ -270,6 +272,7 @@ const Tcl_ObjType tclIntType = { UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; +#ifndef TCL_WIDE_INT_IS_LONG const Tcl_ObjType tclWideIntType = { "wideInt", /* name */ NULL, /* freeIntRepProc */ @@ -277,6 +280,7 @@ const Tcl_ObjType tclWideIntType = { UpdateStringOfWideInt, /* updateStringProc */ SetWideIntFromAny /* setFromAnyProc */ }; +#endif const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ @@ -406,7 +410,9 @@ TclInitObjSubsystem(void) /* For backward compatibility only ... */ Tcl_RegisterObjType(&oldBooleanType); +#ifndef TCL_WIDE_INT_IS_LONG Tcl_RegisterObjType(&tclWideIntType); +#endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); @@ -1909,10 +1915,12 @@ Tcl_GetBooleanFromObj( *boolPtr = 1; return TCL_OK; } +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } +#endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; @@ -1962,9 +1970,11 @@ TclSetBooleanFromAny( goto badBoolean; } +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { goto badBoolean; } +#endif if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; @@ -2292,10 +2302,12 @@ Tcl_GetDoubleFromObj( *dblPtr = TclBignumToDouble(&big); return TCL_OK; } +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } +#endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } @@ -2749,6 +2761,7 @@ Tcl_GetLongFromObj( *longPtr = objPtr->internalRep.longValue; return TCL_OK; } +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { /* * We return any integer in the range -ULONG_MAX to ULONG_MAX @@ -2767,6 +2780,7 @@ Tcl_GetLongFromObj( } goto tooLarge; } +#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2805,7 +2819,9 @@ Tcl_GetLongFromObj( return TCL_OK; } } +#ifndef TCL_WIDE_INT_IS_LONG tooLarge: +#endif if (interp != NULL) { const char *s = "integer value too large to represent"; Tcl_Obj *msg = Tcl_NewStringObj(s, -1); @@ -2819,6 +2835,7 @@ Tcl_GetLongFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } +#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- @@ -2860,6 +2877,7 @@ UpdateStringOfWideInt( memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3014,7 +3032,14 @@ Tcl_SetWideIntObj( && (wideValue <= (Tcl_WideInt) LONG_MAX)) { TclSetLongObj(objPtr, (long) wideValue); } else { +#ifndef TCL_WIDE_INT_IS_LONG TclSetWideIntObj(objPtr, wideValue); +#else + mp_int big; + + TclBNInitBignumFromWideInt(&big, wideValue); + Tcl_SetBignumObj(objPtr, &big); +#endif } } @@ -3047,10 +3072,12 @@ Tcl_GetWideIntFromObj( /* Place to store resulting long. */ { do { +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } +#endif if (objPtr->typePtr == &tclIntType) { *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; return TCL_OK; @@ -3105,6 +3132,7 @@ Tcl_GetWideIntFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } +#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- @@ -3130,6 +3158,7 @@ SetWideIntFromAny( Tcl_WideInt w; return Tcl_GetWideIntFromObj(interp, objPtr, &w); } +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3377,11 +3406,13 @@ GetBignumFromObj( TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); return TCL_OK; } +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { TclBNInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } +#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3514,6 +3545,7 @@ Tcl_SetBignumObj( return; } tooLargeForLong: +#ifndef TCL_WIDE_INT_IS_LONG if ((size_t) bignumValue->used <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; @@ -3539,6 +3571,7 @@ Tcl_SetBignumObj( return; } tooLargeForWide: +#endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); @@ -3624,11 +3657,13 @@ TclGetNumberFromObj( *clientDataPtr = &objPtr->internalRep.longValue; return TCL_OK; } +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } +#endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, diff --git a/generic/tclProc.c b/generic/tclProc.c index 29315b4..10d5fef 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -837,7 +837,9 @@ TclObjGetFrame( } /* TODO: Consider skipping the typePtr checks */ } else if (objPtr->typePtr == &tclIntType +#ifndef TCL_WIDE_INT_IS_LONG || objPtr->typePtr == &tclWideIntType +#endif ) { if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { goto levelError; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 388fff6..30a72ba 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1172,6 +1172,7 @@ TclParseNumber( if (!octalSignificandOverflow) { if (octalSignificandWide > (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { +#ifndef TCL_WIDE_INT_IS_LONG if (octalSignificandWide <= (MOST_BITS + signum)) { objPtr->typePtr = &tclWideIntType; if (signum) { @@ -1183,6 +1184,7 @@ TclParseNumber( } break; } +#endif TclBNInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; @@ -1217,6 +1219,7 @@ TclParseNumber( if (!significandOverflow) { if (significandWide > (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { +#ifndef TCL_WIDE_INT_IS_LONG if (significandWide <= MOST_BITS+signum) { objPtr->typePtr = &tclWideIntType; if (signum) { @@ -1228,6 +1231,7 @@ TclParseNumber( } break; } +#endif TclBNInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 3c3f1a6..16d0a17 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1918,8 +1918,10 @@ Tcl_AppendFormatToObj( useBig = 1; format += step; step = Tcl_UtfToUniChar(format, &ch); +#ifndef TCL_WIDE_INT_IS_LONG } else { useWide = 1; +#endif } } diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 1a88836..2d1cd33 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -819,7 +819,9 @@ Tcl_AfterObjCmd( */ if (objv[1]->typePtr == &tclIntType +#ifndef TCL_WIDE_INT_IS_LONG || objv[1]->typePtr == &tclWideIntType +#endif || objv[1]->typePtr == &tclBignumType || (Tcl_GetIndexFromObjStruct(NULL, objv[1], afterSubCmds, sizeof(char *), "", 0, &index) != TCL_OK)) { @@ -1043,9 +1045,11 @@ AfterDelay( if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); +#ifndef TCL_WIDE_INT_IS_LONG if (diff > LONG_MAX) { diff = LONG_MAX; } +#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } @@ -1056,9 +1060,11 @@ AfterDelay( } else break; } else { diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); +#ifndef TCL_WIDE_INT_IS_LONG if (diff > LONG_MAX) { diff = LONG_MAX; } +#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } -- cgit v0.12 From 2916d083d8e80db13d25190cdc1534aad0cf67ad Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 14 Aug 2013 17:02:41 +0000 Subject: [a16752c252] Correct failure to call cmd deletion callbacks. --- generic/tclBasic.c | 28 +++++----------------------- generic/tclTest.c | 6 +++--- tests/rename.test | 7 +++++++ 3 files changed, 15 insertions(+), 26 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4f24515..8ab3acb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1966,12 +1966,8 @@ Tcl_CreateCommand( * future calls to Tcl_GetCommandName. * * Side effects: - * If no command named "cmdName" already exists for interp, one is - * created. Otherwise, if a command does exist, then if the object-based - * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand - * was called previously for the same command and just set its - * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old - * command. + * If a command named "cmdName" already exists for interp, it is + * first deleted. Then the new command is created from the arguments. * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2039,21 +2035,7 @@ Tcl_CreateObjCommand( cmdPtr = Tcl_GetHashValue(hPtr); /* - * Command already exists. If its object-based Tcl_ObjCmdProc is - * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the - * argument "proc". Otherwise, we delete the old command. - */ - - if (cmdPtr->objProc == TclInvokeStringCommand) { - cmdPtr->objProc = proc; - cmdPtr->objClientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; - return (Tcl_Command) cmdPtr; - } - - /* - * Otherwise, we delete the old command. Be careful to preserve any + * Command already exists; delete it. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. @@ -2188,8 +2170,8 @@ TclInvokeStringCommand( * A standard Tcl string result value. * * Side effects: - * Besides those side effects of the called Tcl_CmdProc, - * TclInvokeStringCommand allocates and frees storage. + * Besides those side effects of the called Tcl_ObjCmdProc, + * TclInvokeObjectCommand allocates and frees storage. * *---------------------------------------------------------------------- */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 9ef7805..5b51baa 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1545,14 +1545,14 @@ DelCallbackProc( * * TestdelCmd -- * - * This procedure implements the "testdcall" command. It is used - * to test Tcl_CallWhenDeleted. + * This procedure implements the "testdel" command. It is used + * to test calling of command deletion callbacks. * * Results: * A standard Tcl result. * * Side effects: - * Creates and deletes interpreters. + * Creates a command. * *---------------------------------------------------------------------- */ diff --git a/tests/rename.test b/tests/rename.test index bd14578..cd90b55 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -135,6 +135,13 @@ test rename-4.7 {reentrancy issues with command deletion and renaming} testdel { if {[info exists env(value)]} { unset env(value) } +test rename-4.8 {Bug a16752c252} testdel { + set x broken + testdel {} foo {set x ok} + proc foo args {} + rename foo {} + return -level 0 $x[unset x] +} ok # Save the unknown procedure which is modified by the following test. -- cgit v0.12 From 83138348a496b45f8806f1bf96d207d789bdff20 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 14 Aug 2013 20:20:11 +0000 Subject: Add several tests to check consistency of stack traces. --- tests/interp.test | 14 ++++++++++ tests/safe.test | 80 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 94 insertions(+) diff --git a/tests/interp.test b/tests/interp.test index 0af9887..ad99fac 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -1599,6 +1599,20 @@ test interp-20.50 {Bug 2486550} -setup { } -cleanup { interp delete slave } -returnCodes error -match glob -result * +test interp-20.50.1 {Bug 2486550} -setup { + interp create slave +} -body { + slave hide coroutine + catch {slave invokehidden coroutine} m o + dict get $o -errorinfo +} -cleanup { + unset -nocomplain m 0 + interp delete slave +} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" + while executing +"coroutine" + invoked from within +"slave invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} diff --git a/tests/safe.test b/tests/safe.test index 4a2792e..859f352 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -425,6 +425,19 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i {load {} Safepkg1}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1" + invoked from within +"interp eval $i {load {} Safepkg1}"} test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { set i [safe::interpCreate -nostatics] interp eval $i {load {} Safepkg1} @@ -444,6 +457,18 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { + set i [safe::interpCreate -nestedloadok] + catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1 x" + invoked from within +"interp eval $i {interp create x; load {} Safepkg1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] @@ -501,6 +526,23 @@ test safe-11.7 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +test safe-11.7.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertfrom} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertfrom ?encoding? data" + while executing +"encoding convertfrom" + invoked from within +"::interp invokehidden interp1 encoding convertfrom" + invoked from within +"encoding convertfrom" + invoked from within +"interp eval $i encoding convertfrom"} test safe-11.8 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -508,6 +550,23 @@ test safe-11.8 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data"} +test safe-11.8.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertto} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertto ?encoding? data" + while executing +"encoding convertto" + invoked from within +"::interp invokehidden interp1 encoding convertto" + invoked from within +"encoding convertto" + invoked from within +"interp eval $i encoding convertto"} test safe-12.1 {glob is restricted [Bug 2906841]} -setup { set i [safe::interpCreate] @@ -715,8 +774,29 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup { lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg } -cleanup { + unset -nocomplain msg interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} +test safe-15.1.1 {safe file ensemble does not surprise code} -setup { + set i [interp create -safe] +} -body { + set result [expr {"file" in [interp hidden $i]}] + lappend result [interp eval $i {tcl::file::split a/b/c}] + lappend result [catch {interp eval $i {tcl::file::isdirectory .}}] + lappend result [interp invokehidden $i file split a/b/c] + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp invokehidden $i file isdirectory .}] + interp expose $i file + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo] +} -cleanup { + unset -nocomplain msg o + interp delete $i +} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file + while executing +"file isdirectory ." + invoked from within +"interp eval $i {file isdirectory .}"}} ### ~ should have no special meaning in paths in safe interpreters test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { -- cgit v0.12 From 77e6fd7e3c4a62f918f3a52cfb48d176c0d9d9a7 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 15 Aug 2013 14:05:02 +0000 Subject: The fix for [3610404] leads to a simplification in the implementation of forward methods. --- generic/tclOOInt.h | 6 ------ generic/tclOOMethod.c | 13 +------------ 2 files changed, 1 insertion(+), 18 deletions(-) diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index ab54964..c0e4022 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -122,12 +122,6 @@ typedef struct ForwardMethod { Tcl_Obj *prefixObj; /* The list of values to use to replace the * object and method name with. Will be a * non-empty list. */ - int fullyQualified; /* If 1, the command name is fully qualified - * and we should let the default Tcl mechanism - * handle the command lookup because it is - * more efficient. If 0, we need to do a - * specialized lookup based on the current - * object's namespace. */ } ForwardMethod; /* diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 0799082..f9f980a 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1338,7 +1338,6 @@ TclOONewForwardInstanceMethod( fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); - fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1380,7 +1379,6 @@ TclOONewForwardMethod( fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); - fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1409,7 +1407,6 @@ InvokeForwardMethod( ForwardMethod *fmPtr = clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, len, skip = contextPtr->skip; - Command *cmdPtr; /* * Build the real list of arguments to use. Note that we know that the @@ -1421,17 +1418,10 @@ InvokeForwardMethod( Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); - - if (fmPtr->fullyQualified) { - cmdPtr = NULL; - } else { - cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(argObjs[0]), - contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); - } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); ((Interp *)interp)->lookupNsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, NULL); } static int @@ -1476,7 +1466,6 @@ CloneForwardMethod( ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; - fm2Ptr->fullyQualified = fmPtr->fullyQualified; Tcl_IncrRefCount(fm2Ptr->prefixObj); *newClientData = fm2Ptr; return TCL_OK; -- cgit v0.12 From 86d682b82273fd98a4259df86f4303bc65a896b6 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 15 Aug 2013 19:55:26 +0000 Subject: Make sure the errors raised by execution traces become errors raised by the traced command, as documented. Deletion of the traced command was supressing that. --- generic/tclBasic.c | 2 +- tests/trace.test | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8ab3acb..314b5fc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3642,7 +3642,7 @@ TclEvalObjvInternal( * implementation. */ - if (cmdEpoch != newEpoch) { + if (traceCode == TCL_OK && cmdEpoch != newEpoch) { checkTraces = 0; if (commandPtr) { Tcl_DecrRefCount(commandPtr); diff --git a/tests/trace.test b/tests/trace.test index 24279f5..9c01908 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -2658,6 +2658,13 @@ test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup { rename dotrace {} rename foo {} } -result {3 | 0 1 1} + +test trace-40.1 {execution trace errors become command errors} { + proc foo args {} + trace add execution foo enter {rename foo {}; error bar;#} + catch foo m + return -level 0 $m[unset m] +} bar # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). -- cgit v0.12 From 7f660cabfb7f9a21f1a60e6e2b06cbd9449b8d13 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 19 Aug 2013 15:22:15 +0000 Subject: Testing doing away with the NRRunObjProc routine, which looks like a useless extra bounce on the NRE trampoline. Normal testing has no problem with it, but debug-enabled testing triggers an assert failure. Either it would be good to have a normal test that fails in the conditions of the assert failure, or it would be good to discover the assert is asserting something not actually required, and then make the purge. --- generic/tclBasic.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4a95340..020f2f2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -133,7 +133,9 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); +#if 0 static Tcl_NRPostProc NRRunObjProc; +#endif static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -4238,9 +4240,13 @@ TclNREvalObjv( */ if (cmdPtr->nreProc) { +#if 0 TclNRAddCallback(interp, NRRunObjProc, cmdPtr, INT2PTR(objc), (ClientData) objv, NULL); return TCL_OK; +#else + return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); +#endif } else { return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); } @@ -4323,6 +4329,7 @@ NRCommand( return result; } +#if 0 static int NRRunObjProc( ClientData data[], @@ -4337,6 +4344,7 @@ NRRunObjProc( return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); } +#endif /* -- cgit v0.12 From 4837b605c2c1f2aa65ba75d080a2cb5076303abd Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 19 Aug 2013 16:34:10 +0000 Subject: Revise execution trace handling to take account of the new reality in Tcl 8.6 that callers can pre-resolve a cmdPtr for us. In that case a re-resolution in the form of another command name lookup isn't the right thing. --- generic/tclBasic.c | 51 +++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 37 insertions(+), 14 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 64563ee..8ac5781 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -148,7 +148,8 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); + Tcl_Obj *const objv[], Namespace *lookupNsPtr, + int weLookUp); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -4098,6 +4099,7 @@ TclNREvalObjv( Namespace *lookupNsPtr = iPtr->lookupNsPtr; Command **cmdPtrPtr; NRE_callback *callbackPtr; + int weLookUp = (cmdPtr == NULL); iPtr->lookupNsPtr = NULL; @@ -4136,7 +4138,7 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (cmdPtr) { + if (!weLookUp) { goto commandFound; } @@ -4188,12 +4190,16 @@ TclNREvalObjv( result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv), objc, objv, lookupNsPtr); + objc, objv), objc, objv, lookupNsPtr, weLookUp); if (result != TCL_OK) { return result; } - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + if (cmdPtr == NULL) { + if (weLookUp) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } + /* Is this right??? */ + return TCL_OK; } } @@ -4605,7 +4611,8 @@ TEOV_RunEnterTraces( Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[], - Namespace *lookupNsPtr) + Namespace *lookupNsPtr, + int weLookUp) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; @@ -4613,7 +4620,7 @@ TEOV_RunEnterTraces( int cmdEpoch = cmdPtr->cmdEpoch; int newEpoch; const char *command; - int length; + int length, deleted; Tcl_IncrRefCount(commandPtr); command = Tcl_GetStringFromObj(commandPtr, &length); @@ -4635,16 +4642,32 @@ TEOV_RunEnterTraces( cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); } newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); - /* - * If the traces modified/deleted the command or any existing traces, they - * will update the command's epoch. We need to lookup again, but do not - * run enter traces on the newly found cmdPtr. - */ - if (cmdEpoch != newEpoch) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + + /* + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. + */ + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } + } *cmdPtrPtr = cmdPtr; } -- cgit v0.12 From 107aa17d8d2388a56f1fd3374e8b49b135e1ae41 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 20 Aug 2013 14:00:05 +0000 Subject: Push out a trial patch for more eyes to see. --- generic/tclBasic.c | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 020f2f2..ca49bec 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -161,6 +161,8 @@ static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; +static Tcl_NRPostProc Dispatch; + static Tcl_ObjCmdProc NRCoroInjectObjCmd; MODULE_SCOPE const TclStubs tclStubs; @@ -4234,6 +4236,9 @@ TclNREvalObjv( *cmdPtrPtr = cmdPtr; cmdPtr->refCount++; + TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL); + return TCL_OK; + /* * Find the objProc to call: nreProc if available, objProc otherwise. Push * a callback to do the actual running. @@ -4252,6 +4257,23 @@ TclNREvalObjv( } } +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = data[0]; + int objc = PTR2INT(data[1]); + Tcl_Obj **objv = data[2]; + + if (cmdPtr->nreProc) { + return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); + } else { + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); + } +} + int TclNRRunCallbacks( Tcl_Interp *interp, -- cgit v0.12 From 7ef78ec33dcd4cf57d272e36d542a1c3c088495a Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 21 Aug 2013 09:35:50 +0000 Subject: define tests for this bug; no fix yet --- tests/oo.test | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index e0e0791..054bc46 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1839,6 +1839,36 @@ test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup { } -returnCodes error -cleanup { Foo destroy } -result {wrong # args: should be "::bar a b"} +test oo-15.10 {variable binding must not bleed through oo::copy} -setup { + oo::class create FooClass + set result {} +} -body { + set obj1 [FooClass new] + oo::objdefine $obj1 { + variable var + method m {} { + set var foo + } + method get {} { + return $var + } + export eval + } + + $obj1 m + lappend result [$obj1 get] + set obj2 [oo::copy $obj1] + $obj2 eval { + set var bar + } + lappend result [$obj2 get] + $obj1 eval { + set var grill + } + lappend result [$obj1 get] [$obj2 get] +} -cleanup { + FooClass destroy +} -result {foo bar grill bar} test oo-16.1 {OO: object introspection} -body { info object -- cgit v0.12 From 3f61f168eb9d98c28312cdea25b214827c3692f2 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 21 Aug 2013 10:25:18 +0000 Subject: [3612422]: Refer to correct part of tclvars(n) rather than page itself. --- doc/AddErrInfo.3 | 12 ++++++------ doc/CrtInterp.3 | 7 ++++--- doc/Environment.3 | 2 +- doc/bgerror.n | 5 ++++- doc/binary.n | 2 +- doc/catch.n | 3 ++- doc/eval.n | 3 ++- doc/info.n | 12 ++++++------ doc/library.n | 10 +++++++--- doc/return.n | 4 ++-- doc/tclsh.1 | 8 +++++--- doc/throw.n | 2 +- 12 files changed, 41 insertions(+), 29 deletions(-) diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index b9c6a63..36f6a20 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -176,16 +176,16 @@ these return options. The \fB\-errorinfo\fR option holds a stack trace of the operations that were in progress when an error occurred, and is intended to be human-readable. -The \fB\-errorcode\fR option holds a list of items that +The \fB\-errorcode\fR option holds a Tcl list of items that are intended to be machine-readable. The first item in the \fB\-errorcode\fR value identifies the class of error that occurred -(e.g. POSIX means an error occurred in a POSIX system call) +(e.g., POSIX means an error occurred in a POSIX system call) and additional elements hold additional pieces of information that depend on the class. -See the \fBtclvars\fR manual entry for details on the various -formats for the \fB\-errorcode\fR option used by -Tcl's built-in commands. +See the manual entry on the \fBerrorCode\fR variable for details on the +various formats for the \fB\-errorcode\fR option used by Tcl's built-in +commands. .PP The \fB\-errorinfo\fR option value is gradually built up as an error unwinds through the nested operations. @@ -307,6 +307,6 @@ so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), -Tcl_SetErrno(3), tclvars(n) +Tcl_SetErrno(3), errorCode(n), errorInfo(n) .SH KEYWORDS error, value, value result, stack, trace, variable diff --git a/doc/CrtInterp.3 b/doc/CrtInterp.3 index a248cf4..1156a20 100644 --- a/doc/CrtInterp.3 +++ b/doc/CrtInterp.3 @@ -41,8 +41,9 @@ may only be passed to Tcl routines called from the same thread as the original \fBTcl_CreateInterp\fR call. It is not safe for multiple threads to pass the same token to Tcl's routines. The new interpreter is initialized with the built-in Tcl commands -and with the variables documented in the \fBtclvars\fR manual page. To bind in -additional commands, call \fBTcl_CreateCommand\fR. +and with standard variables like \fBtcl_platform\fR and \fBenv\fR. To +bind in additional commands, call \fBTcl_CreateCommand\fR, and to +create additional variables, call \fBTcl_SetVar\fR. .PP \fBTcl_DeleteInterp\fR marks an interpreter as deleted; the interpreter will eventually be deleted when all calls to \fBTcl_Preserve\fR for it have @@ -144,6 +145,6 @@ should be used to determine when an interpreter is a candidate for deletion due to inactivity. .VE 8.6 .SH "SEE ALSO" -Tcl_Preserve(3), Tcl_Release(3), tclvars(n) +Tcl_Preserve(3), Tcl_Release(3) .SH KEYWORDS command, create, delete, interpreter diff --git a/doc/Environment.3 b/doc/Environment.3 index 3753f43..46262ab 100644 --- a/doc/Environment.3 +++ b/doc/Environment.3 @@ -33,6 +33,6 @@ Tcl-based applications using \fBputenv\fR should redefine it to \fBTcl_PutEnv\fR so that they will interface properly to the Tcl runtime. .SH "SEE ALSO" -tclvars(n) +env(n) .SH KEYWORDS environment, variable diff --git a/doc/bgerror.n b/doc/bgerror.n index ac53eca..16a23a3 100644 --- a/doc/bgerror.n +++ b/doc/bgerror.n @@ -85,6 +85,9 @@ proc bgerror {message} { } .CE .SH "SEE ALSO" -after(n), interp(n), tclvars(n) +after(n), errorCode(n), errorInfo(n), interp(n) .SH KEYWORDS background error, reporting +'\" Local Variables: +'\" mode: nroff +'\" End: diff --git a/doc/binary.n b/doc/binary.n index 68bf9cc..a40afe6 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -884,7 +884,7 @@ close $f puts [\fBbinary encode\fR base64 \-maxlen 64 $data] .CE .SH "SEE ALSO" -format(n), scan(n), tclvars(n) +format(n), scan(n), tcl_platform(n) .SH KEYWORDS binary, format, scan '\" Local Variables: diff --git a/doc/catch.n b/doc/catch.n index a05ca71..9597ccf 100644 --- a/doc/catch.n +++ b/doc/catch.n @@ -115,7 +115,8 @@ if { [\fBcatch\fR {open $someFile w} fid] } { There are more complex examples of \fBcatch\fR usage in the documentation for the \fBreturn\fR command. .SH "SEE ALSO" -break(n), continue(n), dict(n), error(n), info(n), return(n), tclvars(n) +break(n), continue(n), dict(n), error(n), errorCode(n), errorInfo(n), info(n), +return(n) .SH KEYWORDS catch, error, exception '\" Local Variables: diff --git a/doc/eval.n b/doc/eval.n index da88757..13b54be 100644 --- a/doc/eval.n +++ b/doc/eval.n @@ -75,7 +75,8 @@ However, the last line would now normally be written without set var [linsert $var 0 {*}$args] .CE .SH "SEE ALSO" -catch(n), concat(n), error(n), interp(n), list(n), namespace(n), subst(n), tclvars(n), uplevel(n) +catch(n), concat(n), error(n), errorCode(n), errorInfo(n), interp(n), list(n), +namespace(n), subst(n), uplevel(n) .SH KEYWORDS concatenate, evaluate, script '\" Local Variables: diff --git a/doc/info.n b/doc/info.n index e65a083..14a9e50 100644 --- a/doc/info.n +++ b/doc/info.n @@ -296,7 +296,6 @@ Returns the name of the library directory in which standard Tcl scripts are stored. This is actually the value of the \fBtcl_library\fR variable and may be changed by setting \fBtcl_library\fR. -See the \fBtclvars\fR manual entry for more information. .TP \fBinfo loaded \fR?\fIinterp\fR? . @@ -336,8 +335,8 @@ described in \fBOBJECT INTROSPECTION\fR below. .TP \fBinfo patchlevel\fR . -Returns the value of the global variable \fBtcl_patchLevel\fR; see -the \fBtclvars\fR manual entry for more information. +Returns the value of the global variable \fBtcl_patchLevel\fR, which holds +the exact version of the Tcl library by default. .TP \fBinfo procs \fR?\fIpattern\fR? . @@ -374,8 +373,8 @@ string is returned. .TP \fBinfo tclversion\fR . -Returns the value of the global variable \fBtcl_version\fR; see -the \fBtclvars\fR manual entry for more information. +Returns the value of the global variable \fBtcl_version\fR, which holds the +major and minor version of the Tcl library by default. .TP \fBinfo vars\fR ?\fIpattern\fR? . @@ -763,8 +762,9 @@ proc getDef {obj method} { .VE 8.6 .SH "SEE ALSO" .VS 8.6 -global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n) +global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n), .VE 8.6 +tcl_library(n), tcl_patchLevel(n), tcl_version(n) .SH KEYWORDS command, information, interpreter, introspection, level, namespace, .VS 8.6 diff --git a/doc/library.n b/doc/library.n index 2413692..98dcb35 100644 --- a/doc/library.n +++ b/doc/library.n @@ -262,13 +262,17 @@ If set to any value, then \fBunknown\fR will not attempt to auto-load any commands. .TP \fBauto_path\fR +. If set, then it must contain a valid Tcl list giving directories to -search during auto-load operations. +search during auto-load operations (including for package index +files when using the default \fBpackage unknown\fR handler). This variable is initialized during startup to contain, in order: the directories listed in the \fBTCLLIBPATH\fR environment variable, -the directory named by the \fBtcl_library\fR variable, +the directory named by the \fBtcl_library\fR global variable, the parent directory of \fBtcl_library\fR, the directories listed in the \fBtcl_pkgPath\fR variable. +Additional locations to look for files and package indices should +normally be added to this variable using \fBlappend\fR. .TP \fBenv(TCL_LIBRARY)\fR If set, then it specifies the location of the directory containing @@ -306,7 +310,7 @@ considered to be a word character. On Windows platforms, words are comprised of any character that is not a space, tab, or newline. Under Unix, words are comprised of numbers, letters or underscores. .SH "SEE ALSO" -info(n), re_syntax(n), tclvars(n) +env(n), info(n), re_syntax(n) .SH KEYWORDS auto-exec, auto-load, library, unknown, word, whitespace '\"Local Variables: diff --git a/doc/return.n b/doc/return.n index b59a93d..a1abccf 100644 --- a/doc/return.n +++ b/doc/return.n @@ -317,8 +317,8 @@ proc myReturn {args} { } .CE .SH "SEE ALSO" -break(n), catch(n), continue(n), dict(n), error(n), proc(n), -source(n), tclvars(n), throw(n), try(n) +break(n), catch(n), continue(n), dict(n), error(n), errorCode(n), +errorInfo(n), proc(n), source(n), throw(n), try(n) .SH KEYWORDS break, catch, continue, error, exception, procedure, result, return .\" Local Variables: diff --git a/doc/tclsh.1 b/doc/tclsh.1 index 8e7fb9e..dfc2635 100644 --- a/doc/tclsh.1 +++ b/doc/tclsh.1 @@ -102,7 +102,9 @@ but also the disadvantage of making it harder to write scripts that start up uniformly across different versions of Tcl. .SH "VARIABLES" .PP -\fBTclsh\fR sets the following Tcl variables: +\fBTclsh\fR sets the following global Tcl variables in addition to those +created by the Tcl library itself (such as \fBenv\fR, which maps +environment variables such as \fBPATH\fR into Tcl): .TP 15 \fBargc\fR . @@ -129,7 +131,7 @@ device), 0 otherwise. When \fBtclsh\fR is invoked interactively it normally prompts for each command with .QW "\fB% \fR" . -You can change the prompt by setting the +You can change the prompt by setting the global variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable \fBtcl_prompt1\fR exists then it must consist of a Tcl script to output a prompt; instead of outputting a prompt \fBtclsh\fR @@ -142,6 +144,6 @@ incomplete commands. .PP See \fBTcl_StandardChannels\fR for more explanations. .SH "SEE ALSO" -encoding(n), fconfigure(n), tclvars(n) +auto_path(n), encoding(n), env(n), fconfigure(n) .SH KEYWORDS application, argument, interpreter, prompt, script file, shell diff --git a/doc/throw.n b/doc/throw.n index d49fb24..b28f2e4 100644 --- a/doc/throw.n +++ b/doc/throw.n @@ -40,7 +40,7 @@ The following produces an error that is identical to that produced by \fBthrow\fR {ARITH DIVZERO {divide by zero}} {divide by zero} .CE .SH "SEE ALSO" -catch(n), error(n), return(n), tclvars(n), try(n) +catch(n), error(n), errorCode(n), errorInfo(n), return(n), try(n) .SH "KEYWORDS" error, exception '\" Local Variables: -- cgit v0.12 From b9100f680a4f29439312a01ce54c8340b5d53374 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Aug 2013 18:27:23 +0000 Subject: Don't use automatic storage to hold the invocation words of oo::define. That practice doesn't agree with NRE execution. --- generic/tclOOBasic.c | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index f8cd1a4..073abab 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -88,7 +88,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj *invoke[3]; + Tcl_Obj **invoke = ckalloc(3 * sizeof(Tcl_Obj *)); if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -115,7 +115,7 @@ TclOO_Class_Constructor( Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke[0], invoke[1], invoke[2], NULL); + invoke, NULL, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack @@ -131,9 +131,12 @@ DecrRefsPostClassConstructor( Tcl_Interp *interp, int result) { - TclDecrRefCount((Tcl_Obj *) data[0]); - TclDecrRefCount((Tcl_Obj *) data[1]); - TclDecrRefCount((Tcl_Obj *) data[2]); + Tcl_Obj **invoke = data[0]; + + TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); + TclDecrRefCount(invoke[2]); + ckfree(invoke); return result; } -- cgit v0.12 From 88f6a82f096bab2c48289cf27f99c6f2df66da9b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Aug 2013 19:00:17 +0000 Subject: Don't allocate memory until you know you're going to use it and arrange for it to be freed. Leak! --- generic/tclOOBasic.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 073abab..aba06a5 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -88,7 +88,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj **invoke = ckalloc(3 * sizeof(Tcl_Obj *)); + Tcl_Obj **invoke; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -102,6 +102,7 @@ TclOO_Class_Constructor( * Delegate to [oo::define] to do the work. */ + invoke = ckalloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; -- cgit v0.12 From cb779b2f4466180ab1678cc0a9e38159704b7efd Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Aug 2013 19:18:28 +0000 Subject: Tidy the code and add a test. --- generic/tclBasic.c | 39 --------------------------------------- tests/coroutine.test | 9 +++++++++ 2 files changed, 9 insertions(+), 39 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ca49bec..c1032f9 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -133,9 +133,6 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); -#if 0 -static Tcl_NRPostProc NRRunObjProc; -#endif static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -160,7 +157,6 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; - static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; @@ -4238,23 +4234,6 @@ TclNREvalObjv( TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL); return TCL_OK; - - /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. - */ - - if (cmdPtr->nreProc) { -#if 0 - TclNRAddCallback(interp, NRRunObjProc, cmdPtr, - INT2PTR(objc), (ClientData) objv, NULL); - return TCL_OK; -#else - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); -#endif - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } } static int @@ -4350,24 +4329,6 @@ NRCommand( return result; } - -#if 0 -static int -NRRunObjProc( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* OPT: do not call? */ - - Command* cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); -} -#endif - /* *---------------------------------------------------------------------- diff --git a/tests/coroutine.test b/tests/coroutine.test index 1d9040b..faa5a42 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -609,6 +609,15 @@ 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 { + rename foo {} +} -body { + coroutine demo lsort -command foo {a b} +} -result {b a} + # cleanup unset lambda -- cgit v0.12 From ff681132dc338549a4dc9fc52cdb33e2ea1ce37f Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 22 Aug 2013 08:07:33 +0000 Subject: Correction to documentation --- doc/Method.3 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/Method.3 b/doc/Method.3 index 43b3609..2537d5e 100644 --- a/doc/Method.3 +++ b/doc/Method.3 @@ -172,8 +172,9 @@ typedef struct { .PP The \fIversion\fR field allows for future expansion of the structure, and should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT. The -\fIname\fR field provides a human-readable name for the type, and is reserved -for debugging. +\fIname\fR field provides a human-readable name for the type, and is the value +that is exposed via the \fBinfo class methodtype\fR and +\fBinfo object methodtype\fR Tcl commands. .PP The \fIcallProc\fR field gives a function that is called when the method is invoked; it must never be NULL. -- cgit v0.12 From 6bdb21a3a0573fcd1a3750d8f163f624d4e07a69 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 13:01:31 +0000 Subject: More coroutine tests. --- tests/coroutine.test | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index faa5a42..8a7fdf3 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -618,6 +618,21 @@ test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { 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} { + lappend result [catch {coroutine demo return -level 0 -code $code}] + } + 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 {} +} {} + # cleanup unset lambda -- cgit v0.12 From f8dfc60a3d144141a5b93a3b9326e162cbf5cdef Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 16:13:29 +0000 Subject: Remove assertion that is not true in some circumstances (--enable-dtrace). --- generic/tclExecute.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d066476..96004e2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8798,8 +8798,7 @@ TclGetSrcInfoForPc( &cfPtr->len, NULL, NULL); } - assert(cfPtr->cmd != NULL); - { + if (cfPtr->cmd != NULL) { /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. -- cgit v0.12 From f12764701b58ae91225b1ce8311378ef722b7a00 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 20:21:15 +0000 Subject: Make Dispatch() the single point for calling a Tcl_ObjCmdProc, and attach the DTRACE machinery there (one place, not two). --- generic/tclBasic.c | 91 +++++++++++++++++++----------------------------------- 1 file changed, 32 insertions(+), 59 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c1032f9..5371f31 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4196,6 +4196,31 @@ TclNREvalObjv( } } + /* + * Fix the original callback to point to the now known cmdPtr. Insure that + * the Command struct lives until the command returns. + */ + + *cmdPtrPtr = cmdPtr; + cmdPtr->refCount++; + + TclNRAddCallback(interp, Dispatch, + cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, + cmdPtr->objClientData, INT2PTR(objc), objv); + return TCL_OK; +} + +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_ObjCmdProc *objProc = data[0]; + ClientData clientData = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { @@ -4216,41 +4241,17 @@ TclNREvalObjv( TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } - if (TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) { + if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) + && objc) { TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); } - if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); } #endif /* USE_DTRACE */ - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - - TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL); - return TCL_OK; -} - -static int -Dispatch( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Command *cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - if (cmdPtr->nreProc) { - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } + return objProc(clientData, interp, objc, objv); } int @@ -7981,39 +7982,11 @@ Tcl_NRCallObjProc( int objc, Tcl_Obj *const objv[]) { - int result = TCL_OK; NRE_callback *rootPtr = TOP_CB(interp); -#ifdef USE_DTRACE - if (TCL_DTRACE_CMD_ARGS_ENABLED()) { - const char *a[10]; - int i = 0; - - while (i < 10) { - a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; - } - TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], - a[8], a[9]); - } - if (TCL_DTRACE_CMD_INFO_ENABLED() && ((Interp *) interp)->cmdFramePtr) { - Tcl_Obj *info = TclInfoFrame(interp, ((Interp *) interp)->cmdFramePtr); - const char *a[6]; int i[2]; - - TclDTraceInfo(info, a, i); - TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); - TclDecrRefCount(info); - } - if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) - && objc) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } -#endif /* USE_DTRACE */ - result = objProc(clientData, interp, objc, objv); - return TclNRRunCallbacks(interp, result, rootPtr); + TclNRAddCallback(interp, Dispatch, objProc, clientData, + INT2PTR(objc), objv); + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } /* -- cgit v0.12 From b3792d779d73852a163fd142bbb96acc46c98153 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 20:34:30 +0000 Subject: compiler warning --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5371f31..fc449cc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4220,9 +4220,9 @@ Dispatch( ClientData clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; +#ifdef USE_DTRACE Interp *iPtr = (Interp *) interp; -#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; -- cgit v0.12 From c3b526dd8620621345e9c5ff0f72234cff838715 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Aug 2013 05:59:48 +0000 Subject: Remove complications that no longer server any required purpose. --- generic/tclBasic.c | 20 +------------------- 1 file changed, 1 insertion(+), 19 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fc449cc..4d56f3a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4095,8 +4095,6 @@ TclNREvalObjv( Interp *iPtr = (Interp *) interp; int result; Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Command **cmdPtrPtr; - NRE_callback *callbackPtr; iPtr->lookupNsPtr = NULL; @@ -4111,13 +4109,10 @@ TclNREvalObjv( */ if (iPtr->deferredCallbacks) { - callbackPtr = iPtr->deferredCallbacks; iPtr->deferredCallbacks = NULL; } else { TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - callbackPtr = TOP_CB(interp); } - cmdPtrPtr = (Command **) &(callbackPtr->data[0]); iPtr->numLevels++; result = TclInterpReady(interp); @@ -4196,14 +4191,6 @@ TclNREvalObjv( } } - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - TclNRAddCallback(interp, Dispatch, cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, cmdPtr->objClientData, INT2PTR(objc), objv); @@ -4297,13 +4284,8 @@ NRCommand( int result) { Interp *iPtr = (Interp *) interp; - Command *cmdPtr = data[0]; - /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */ - if (cmdPtr) { - TclCleanupCommandMacro(cmdPtr); - } - ((Interp *)interp)->numLevels--; + iPtr->numLevels--; /* * If there is a tailcall, schedule it -- cgit v0.12 From 19fa970aea5f91d40bff7847090106710637151e Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 23 Aug 2013 13:08:15 +0000 Subject: fix NRE docs --- doc/NRE.3 | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index 7ebeb39..a27a359 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -8,7 +8,8 @@ .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, +Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include \fR @@ -207,7 +208,7 @@ is something like: .PP .CS int -\fITheCmdObjProc\fR( +\fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, @@ -225,7 +226,7 @@ int return result; } \fBTcl_CreateObjCommand\fR(interp, "theCommand", - \fITheCmdObjProc\fR, clientData, TheCmdDeleteProc); + \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP To enable a command like this one for trampoline-based evaluation, @@ -255,8 +256,8 @@ int int objc, Tcl_Obj *const objv[]) { - return \fBTcl_NRCallObjProc\fR(interp, name, - \fITheCmdNRObjProc\fR, clientData, objc, objv); + return \fBTcl_NRCallObjProc\fR(interp, \fITheCmdNRObjProc\fR, + clientData, objc, objv); } .CE .PP @@ -317,7 +318,7 @@ and the second is for use when there is already a trampoline in place. .PP .CS \fBTcl_NRCreateCommand\fR(interp, "theCommand", - \fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData, + \fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData, TheCmdDeleteProc); .CE .SH "SEE ALSO" -- cgit v0.12 From 0ae283a82593a1994e6ed6e5c7577603fa7f72bb Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Aug 2013 16:23:47 +0000 Subject: Make sure all Tcl_NR*Eval*() routines do a schedule only. No errors raised. --- generic/tclBasic.c | 49 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 32 insertions(+), 17 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4d56f3a..96d74c4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -157,6 +157,7 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; +static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; @@ -4093,16 +4094,8 @@ TclNREvalObjv( * requested Command struct to be invoked. */ { Interp *iPtr = (Interp *) interp; - int result; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - - iPtr->lookupNsPtr = NULL; /* - * Push a callback with cleanup tasks for commands; the cmdPtr at data[0] - * will be filled later when the command is found: save its address at - * objProcPtr. - * * data[1] stores a marker for use by tailcalls; it will be set to 1 by * command redirectors (imports, alias, ensembles) so that tailcalls * finishes the source command and not just the target. @@ -4115,12 +4108,38 @@ TclNREvalObjv( } iPtr->numLevels++; - result = TclInterpReady(interp); + TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), + INT2PTR(objc), objv); + return TCL_OK; +} - if ((result != TCL_OK) || (objc == 0)) { - return result; +static int +EvalObjvCore( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = data[0]; + int flags = PTR2INT(data[1]); + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = iPtr->lookupNsPtr; + + if (TCL_OK != TclInterpReady(interp)) { + return TCL_ERROR; } + if (objc == 0) { + return TCL_OK; + } + + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } + + iPtr->lookupNsPtr = NULL; + if (cmdPtr) { goto commandFound; } @@ -4164,11 +4183,6 @@ TclNREvalObjv( return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } - iPtr->cmdCount++; - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; - } - /* * Found a command! The real work begins now ... */ @@ -4207,9 +4221,9 @@ Dispatch( ClientData clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; -#ifdef USE_DTRACE Interp *iPtr = (Interp *) interp; +#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; @@ -4238,6 +4252,7 @@ Dispatch( } #endif /* USE_DTRACE */ + iPtr->cmdCount++; return objProc(clientData, interp, objc, objv); } -- cgit v0.12 From 8463ceabbba1e8736e395eda5a6f37428dc9c12c Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 24 Aug 2013 09:42:43 +0000 Subject: Unbreak doc; the apropos index entry *must* be one line. (This is an external constraint forced by the requirement to fit into the standard Unix manual system.) --- doc/NRE.3 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index a27a359..ce609e6 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -8,8 +8,7 @@ .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, -Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include \fR -- cgit v0.12 From 9150a7225d0e28174587948bb96b6a11f70493dc Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 18:11:53 +0000 Subject: Add test for Bug 2486550. --- tests/coroutine.test | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index 8a7fdf3..03c63ad 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -633,6 +633,15 @@ test coroutine-7.6 {Early yield crashes} { rename foo {} } {} +test coroutine-7.7 {Bug 2486550} -setup { + interp hide {} yield +} -body { + coroutine demo interp invokehidden {} yield ok +} -cleanup { + demo + interp expose {} yield +} -result ok + # cleanup unset lambda -- cgit v0.12 From f300f251bd0a7b4aeb3ee2ad971c5b766629ed04 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:03:57 +0000 Subject: Inline TEOV_RunEnterTraces() so its interface can be redesigned. --- generic/tclBasic.c | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 71 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 82aa833..8407edb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4197,9 +4197,77 @@ EvalObjvCore( * necessary. */ - result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv), objc, objv, lookupNsPtr, weLookUp); + int traceCode = TCL_OK; + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + const char *command; + int length, deleted; + + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); + + Tcl_IncrRefCount(commandPtr); + command = Tcl_GetStringFromObj(commandPtr, &length); + + /* + * Call trace functions. + * Execute any command or execution traces. Note that we bump up the + * command's reference count for the duration of the calling of the traces + * so that the structure doesn't go away underneath our feet. + */ + + cmdPtr->refCount++; + if (iPtr->tracePtr) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; + TclCleanupCommandMacro(cmdPtr); + + if (cmdEpoch != newEpoch) { + + /* + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. + */ + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } + } + } + + if (cmdPtr && (traceCode == TCL_OK)) { + /* + * Command was found: push a record to schedule the leave traces. + */ + + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); + cmdPtr->refCount++; + } else { + Tcl_DecrRefCount(commandPtr); + } + result = traceCode; + if (result != TCL_OK) { return result; } -- cgit v0.12 From 7ddfa6aeb8f6eb66f66f4ae36b5ee59cc56524f6 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:06:08 +0000 Subject: Exceptions raised from enter traces take priority over re-resolution games. --- generic/tclBasic.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8407edb..172c698 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4230,6 +4230,11 @@ EvalObjvCore( deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); + if (traceCode != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return traceCode; + } + if (cmdEpoch != newEpoch) { /* @@ -4255,7 +4260,7 @@ EvalObjvCore( } } - if (cmdPtr && (traceCode == TCL_OK)) { + if (cmdPtr) { /* * Command was found: push a record to schedule the leave traces. */ @@ -4266,11 +4271,6 @@ EvalObjvCore( } else { Tcl_DecrRefCount(commandPtr); } - result = traceCode; - - if (result != TCL_OK) { - return result; - } if (cmdPtr == NULL) { if (weLookUp) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); -- cgit v0.12 From 9ba19b667f4232117cc4abd68576dead47e19c10 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:25:15 +0000 Subject: Tidy up indenting for clarity in refactoring. --- generic/tclBasic.c | 123 +++++++++++++++++++++++++++-------------------------- 1 file changed, 62 insertions(+), 61 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 172c698..3f579d1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4197,80 +4197,81 @@ EvalObjvCore( * necessary. */ - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; + int traceCode = TCL_OK; + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + const char *command; + int length, deleted; - Tcl_Obj *commandPtr = TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv); + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); + Tcl_IncrRefCount(commandPtr); + command = Tcl_GetStringFromObj(commandPtr, &length); - /* - * Call trace functions. - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. - */ + /* + * Call trace functions. + * Execute any command or execution traces. Note that we bump up the + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. + */ - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; - TclCleanupCommandMacro(cmdPtr); + cmdPtr->refCount++; + if (iPtr->tracePtr) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; + TclCleanupCommandMacro(cmdPtr); - if (traceCode != TCL_OK) { - Tcl_DecrRefCount(commandPtr); - return traceCode; - } + if (traceCode != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return traceCode; + } - if (cmdEpoch != newEpoch) { - - /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. - */ - if (weLookUp) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { + if (cmdEpoch != newEpoch) { /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. */ - if (deleted) { - cmdPtr = NULL; + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } } } - } - if (cmdPtr) { - /* - * Command was found: push a record to schedule the leave traces. - */ + if (cmdPtr) { + /* + * Command was found: push a record to schedule the leave traces. + */ + + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); + cmdPtr->refCount++; + } else { + Tcl_DecrRefCount(commandPtr); + } - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); - } if (cmdPtr == NULL) { if (weLookUp) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); -- cgit v0.12 From 3aa655bce1d9e291450cc8bdfe5890058dcf1700 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 Aug 2013 02:44:50 +0000 Subject: Clarfy and prettify influence of flag settings and command lookups. --- generic/tclBasic.c | 77 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 40 insertions(+), 37 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3f579d1..af747cd 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4121,13 +4121,21 @@ EvalObjvCore( Tcl_Interp *interp, int result) { - Command *cmdPtr = data[0]; + Command *cmdPtr = NULL, *preCmdPtr = data[0]; int flags = PTR2INT(data[1]); int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + + /* + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + */ + Namespace *lookupNsPtr = iPtr->lookupNsPtr; - int weLookUp = (cmdPtr == NULL); + iPtr->lookupNsPtr = NULL; if (TCL_OK != TclInterpReady(interp)) { return TCL_ERROR; @@ -4141,8 +4149,6 @@ EvalObjvCore( return TCL_ERROR; } - iPtr->lookupNsPtr = NULL; - /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4152,45 +4158,43 @@ EvalObjvCore( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (!weLookUp) { - goto commandFound; - } - - /* - * Configure evaluation context to match the requested flags. - */ - - if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { - if (!lookupNsPtr) { - lookupNsPtr = iPtr->globalNsPtr; - } + if (preCmdPtr) { + cmdPtr = preCmdPtr; } else { - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } /* - * TCL_EVAL_INVOKE was not set: clear rewrite rules + * Configure evaluation context to match the requested flags. */ - iPtr->ensembleRewrite.sourceObjs = NULL; - } + if (lookupNsPtr) { + /* + * Do nothing. Caller gave us the lookup namespace. Use it. + * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + */ + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; + } else { - /* - * Lookup the command - */ + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); - } + iPtr->ensembleRewrite.sourceObjs = NULL; - /* - * Found a command! The real work begins now ... - */ + if (flags & TCL_EVAL_GLOBAL) { + /* TODO: Check we do this whenever needed. */ + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } + } + + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } + + } - commandFound: if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { /* * Call enter traces. They will schedule a call to the leave traces if @@ -4244,7 +4248,7 @@ EvalObjvCore( * If we got the trace command by looking up a command name, we * should just look it up again. */ - if (weLookUp) { + if (preCmdPtr == NULL) { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); } else { @@ -4273,7 +4277,7 @@ EvalObjvCore( } if (cmdPtr == NULL) { - if (weLookUp) { + if (preCmdPtr == NULL) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } /* Is this right??? */ @@ -4798,7 +4802,6 @@ TEOV_LookupCmdFromObj( if (lookupNsPtr) { iPtr->varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); iPtr->varFramePtr->nsPtr = savedNsPtr; -- cgit v0.12 From 09922916778d4f09686dbdb94e6e4716ab9b8f59 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 Aug 2013 18:05:07 +0000 Subject: Rework the re-resolution after enter traces machinery with cleaner separations and neater interfaces. --- generic/tclBasic.c | 214 +++++++++++++++++------------------------------------ 1 file changed, 69 insertions(+), 145 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index af747cd..bafb4c2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -147,8 +147,7 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr, - int weLookUp); + Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -4126,6 +4125,7 @@ EvalObjvCore( int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + int enterTracesDone = 0; /* * Capture the namespace we should do command name resolution in, as @@ -4152,137 +4152,100 @@ EvalObjvCore( /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). + * TODO: Consider moving this up. */ if (!(flags & TCL_EVAL_NOERR)) { TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (preCmdPtr) { - cmdPtr = preCmdPtr; - } else { + /* + * Configure evaluation context to match the requested flags. + */ + if (lookupNsPtr) { /* - * Configure evaluation context to match the requested flags. + * Do nothing. Caller gave us the lookup namespace. Use it. + * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + * TODO: Is that a bug? */ + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; + } else { - if (lookupNsPtr) { - /* - * Do nothing. Caller gave us the lookup namespace. Use it. - * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. - */ - } else if (flags & TCL_EVAL_INVOKE) { - lookupNsPtr = iPtr->globalNsPtr; - } else { - - /* - * TCL_EVAL_INVOKE was not set: clear rewrite rules - */ + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ - iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.sourceObjs = NULL; - if (flags & TCL_EVAL_GLOBAL) { - /* TODO: Check we do this whenever needed. */ - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; } + } + reresolve: + if (preCmdPtr) { + if (preCmdPtr->flags & CMD_IS_DELETED) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to invoke a deleted command")); + Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); + return TCL_ERROR; + } + cmdPtr = preCmdPtr; + } else { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); if (!cmdPtr) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } - } - if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - /* - * Call enter traces. They will schedule a call to the leave traces if - * necessary. - */ - - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; + if (enterTracesDone || iPtr->tracePtr + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { Tcl_Obj *commandPtr = TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, objc, objv); - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); - /* - * Call trace functions. - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the - * traces so that the structure doesn't go away underneath our feet. - */ + if (!enterTracesDone) { - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; - TclCleanupCommandMacro(cmdPtr); - - if (traceCode != TCL_OK) { - Tcl_DecrRefCount(commandPtr); - return traceCode; - } - - if (cmdEpoch != newEpoch) { + int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + objc, objv); /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. + * Send any exception from enter traces back as an exception + * raised by the traced command. */ - if (preCmdPtr == NULL) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { - /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. - */ - if (deleted) { - cmdPtr = NULL; - } + if (code != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return code; } - } - if (cmdPtr) { /* - * Command was found: push a record to schedule the leave traces. + * If the enter traces made the resolved cmdPtr unusable, go + * back and resolve again, but next time don't run enter + * traces again. */ - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); - } - - if (cmdPtr == NULL) { - if (preCmdPtr == NULL) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + if (cmdPtr == NULL) { + enterTracesDone = 1; + Tcl_DecrRefCount(commandPtr); + goto reresolve; } - /* Is this right??? */ - return TCL_OK; } + + /* + * Schedule leave traces. Raise the refCount on the resolved + * cmdPtr, so that when it passes to the leave traces we know + * it's still valid. + */ + + cmdPtr->refCount++; + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); } TclNRAddCallback(interp, Dispatch, @@ -4672,26 +4635,19 @@ TEOV_RunEnterTraces( Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr, - int weLookUp) + Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; - - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int length, traceCode = TCL_OK; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. */ cmdPtr->refCount++; @@ -4704,47 +4660,15 @@ TEOV_RunEnterTraces( cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); } newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); - if (cmdEpoch != newEpoch) { - - /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. - */ - if (weLookUp) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { - - /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. - */ - if (deleted) { - cmdPtr = NULL; - } - } - *cmdPtrPtr = cmdPtr; + if (traceCode != TCL_OK) { + return traceCode; } - - if (cmdPtr && (traceCode == TCL_OK)) { - /* - * Command was found: push a record to schedule the leave traces. - */ - - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); + if (cmdEpoch != newEpoch) { + *cmdPtrPtr = NULL; } - return traceCode; + return TCL_OK; } static int -- cgit v0.12 From 012f63b012e81a2c53f6fef7a69cf7672d630a94 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 29 Aug 2013 17:59:36 +0000 Subject: New internal eval flag value so that all TclNREvalObjv() callers that pre-resolve command names can choose whether or not TclNREvalObjv() should attempt to re-do the resolution from objv[0] when something goes wrong. --- generic/tclBasic.c | 75 ++++++++++++++++++++++++++++++++++-------------------- generic/tclInt.h | 1 + 2 files changed, 49 insertions(+), 27 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index bafb4c2..884b5cc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4125,18 +4125,18 @@ EvalObjvCore( int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = NULL; int enterTracesDone = 0; - + /* - * Capture the namespace we should do command name resolution in, as - * instructed by our caller sneaking it in to us in a private interp - * field. Clear that field right away so we cannot possibly have its - * use leak where it should not. The sneaky message pass is done. + * Push records for task to be done on return, in INVERSE order. First, if + * needed, the exception handlers (as they should happen last). */ - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - iPtr->lookupNsPtr = NULL; - + if (!(flags & TCL_EVAL_NOERR)) { + TEOV_PushExceptionHandlers(interp, objc, objv, flags); + } + if (TCL_OK != TclInterpReady(interp)) { return TCL_ERROR; } @@ -4150,25 +4150,23 @@ EvalObjvCore( } /* - * Push records for task to be done on return, in INVERSE order. First, if - * needed, the exception handlers (as they should happen last). - * TODO: Consider moving this up. - */ - - if (!(flags & TCL_EVAL_NOERR)) { - TEOV_PushExceptionHandlers(interp, objc, objv, flags); - } - - /* * Configure evaluation context to match the requested flags. */ - if (lookupNsPtr) { + if (iPtr->lookupNsPtr) { + /* - * Do nothing. Caller gave us the lookup namespace. Use it. - * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + * + * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. * TODO: Is that a bug? */ + + lookupNsPtr = iPtr->lookupNsPtr; + iPtr->lookupNsPtr = NULL; } else if (flags & TCL_EVAL_INVOKE) { lookupNsPtr = iPtr->globalNsPtr; } else { @@ -4185,16 +4183,29 @@ EvalObjvCore( } } + /* + * Lookup the Command to dispatch. + */ + reresolve: + assert(cmdPtr == NULL); if (preCmdPtr) { - if (preCmdPtr->flags & CMD_IS_DELETED) { + /* Caller gave it to us */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + /* So long as it exists, use it. */ + cmdPtr = preCmdPtr; + } else if (flags & TCL_EVAL_NORESOLVE) { + /* + * When it's been deleted, and we're told not to attempt + * resolving it ourselves, all we can do is raise an error. + */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to invoke a deleted command")); Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); return TCL_ERROR; } - cmdPtr = preCmdPtr; - } else { + } + if (cmdPtr == NULL) { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); if (!cmdPtr) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); @@ -4217,6 +4228,11 @@ EvalObjvCore( /* * Send any exception from enter traces back as an exception * raised by the traced command. + * TODO: Is this a bug? Letting an execution trace BREAK or + * CONTINUE or RETURN in the place of the traced command? + * Would either converting all exceptions to TCL_ERROR, or + * just swallowing them be better? (Swallowing them has the + * problem of permanently hiding program errors.) */ if (code != TCL_OK) { @@ -6524,9 +6540,14 @@ TclNRInvoke( /* Avoid the exception-handling brain damage when numLevels == 0 . */ iPtr->numLevels++; Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); - - /* TODO: how to get re-resolution right */ - return TclNREvalObjv(interp, objc, objv, 0, cmdPtr); + + /* + * Normal command resolution of objv[0] isn't going to find cmdPtr. + * That's the whole point of **hidden** commands. So tell the + * Eval core machinery not to even try (and risk finding something wrong). + */ + + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); } static int diff --git a/generic/tclInt.h b/generic/tclInt.h index e0e694f..380284f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2201,6 +2201,7 @@ typedef struct Interp { #define TCL_ALLOW_EXCEPTIONS 0x04 #define TCL_EVAL_FILE 0x02 #define TCL_EVAL_SOURCE_IN_FRAME 0x10 +#define TCL_EVAL_NORESOLVE 0x20 /* * Flag bits for Interp structures: -- cgit v0.12 From 4874c0a0af9a15df8fc4b0994370a5d44fda5e44 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 29 Aug 2013 20:08:04 +0000 Subject: Bump to 8.5.15 for release. --- ChangeLog | 13 +++++++++++++ README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- tools/tcl.wse.in | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 10 files changed, 23 insertions(+), 10 deletions(-) diff --git a/ChangeLog b/ChangeLog index 02472fe..032bfc7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +2013-04-03 Don Porter + + * generic/tcl.h: Bump to 8.5.15 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + 2013-08-01 Harald Oehlmann * tclUnixNotify.c Tcl_InitNotifier: Bug [a0bc856dcd] diff --git a/README b/README index 0b3cf05..2ad171f 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.5.14 source distribution. + This is the Tcl 8.5.15 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index be5e697..eeff36e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -58,10 +58,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 5 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 14 +#define TCL_RELEASE_SERIAL 15 #define TCL_VERSION "8.5" -#define TCL_PATCH_LEVEL "8.5.14" +#define TCL_PATCH_LEVEL "8.5.15" /* * The following definitions set up the proper options for Windows compilers. diff --git a/library/init.tcl b/library/init.tcl index 071e6df..6b49fdf 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.5.14 +package require -exact Tcl 8.5.15 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in index aac4413..e22b74a 100644 --- a/tools/tcl.wse.in +++ b/tools/tcl.wse.in @@ -12,7 +12,7 @@ item: Global Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 - Disk Label=tcl8.5.14 + Disk Label=tcl8.5.15 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 diff --git a/unix/configure b/unix/configure index 217e5d4..d7bd53b 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 37de8be..b5a09dd 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index f7705fd..b61f4bf 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.5.14 +Version: 8.5.15 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index a1c0f6d..a0be0c4 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 diff --git a/win/configure.in b/win/configure.in index 33bf784..ea25843 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 -- cgit v0.12 From d3fcbfab11472daf6c82fb0ecdecfa136a310cbe Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 14:16:05 +0000 Subject: changes --- changes | 45 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/changes b/changes index 78ade0e..2221400 100644 --- a/changes +++ b/changes @@ -7735,6 +7735,49 @@ Many revisions to better support a Cygwin environment (nijtmans) --- Released 8.5.14, April 3, 2013 --- See ChangeLog for details --- -2013-05-08 (bug fix)[3036566] Honor language packs on Vista+ to get initial locale (oehlmann) +2013-04-03 (bug fix)[3205320] outsmart gcc on powerpc detect stack direction + +2013-04-04 (bug fix) Support URLs with query but no path (max) +=> http 2.7.12 + +2013-04-08 (bug fix)[3610026] regexp crash on color overflow (linnakangas) + +2013-04-16 (bug fix)[3610404] crash in enter traces (found with TclOO) (porter) + +2013-04-30 (enhancement) broaden glibc version detection (kupries) +=> platform 1.0.12 + +2013-05-01 (bug fix)[2901998] inconsistent I/O buffering (ferrieux) + +2013-05-06 (platform support) Cygwin64 (nijtmans) + +2013-05-16 (platform support) mingw-4.0 (nijtmans) + +2013-05-19 (platform support) FreeBSD updates (cerutti) + +2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows) + +2013-05-28 (bug fix)[3036566] Use language packs (Vista+) locale (oehlmann) => msgcat 1.5.2 +2013-06-03 Restored lost performance appending to long strings (elby,porter) + +2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans) + +2013-06-17 [string is space \u180e] => 1 (nijtmans) + +2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) + +2013-06-27 (bug fix)[32afa6] corrected dirent64 check (griffin) + +2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) + +2013-07-26 (bug fix)[6585b2] regexp {(\w).*?\1} abb (lane) + +2013-07-29 [string is space \u202f] => 1 (nijtmans) + +2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) + +2013-08-15 Errors from execution traces become errors of the command (porter) + +--- Released 8.5.15, September 16, 2013 --- See ChangeLog for details --- -- cgit v0.12 From f9d0c02e5020b9f06c1ba46c1e5820b35fe2ff8b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 14:31:06 +0000 Subject: fix date --- ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 032bfc7..fca182b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,4 @@ -2013-04-03 Don Porter +2013-08-30 Don Porter * generic/tcl.h: Bump to 8.5.15 for release. * library/init.tcl: -- cgit v0.12 From 1d512f82013b5c80636c8522357aabe3b429f143 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 21:57:26 +0000 Subject: Bump to tcltest 2.3.6 to account for changes since Tcl 8.6.0 release. --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 4b0a9bc..60a9485 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.5 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d6e6487..c30d2e4 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.5 + variable Version 2.3.6 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] diff --git a/unix/Makefile.in b/unix/Makefile.in index 443e70d..505f7e0 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -850,8 +850,8 @@ install-libraries: libraries 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.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.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 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 47f3fdd..5109e7a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -650,8 +650,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.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.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 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 a1f0dd74ffe8b407f725f089784f2dd51c2ab548 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 22:04:12 +0000 Subject: Bump version number to 8.6.1. --- ChangeLog | 12 ++++++++++++ README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 9 files changed, 21 insertions(+), 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index ddde893..13fd83b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2013-08-30 Don Porter + + * generic/tcl.h: Bump version number to 8.6.1. + * library/init.tcl: + * unix/configure.in: + * win/configure.in: + * unix/tcl.spec: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + 2013-08-03 Donal Fellows * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found diff --git a/README b/README index 8ecd7a9..7004bc5 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6.0 source distribution. + This is the Tcl 8.6.1 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index a833218..1b120fb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 0 +#define TCL_RELEASE_SERIAL 1 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.0" +#define TCL_PATCH_LEVEL "8.6.1" /* *---------------------------------------------------------------------------- diff --git a/library/init.tcl b/library/init.tcl index bedc06e..1ca6413 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6.0 +package require -exact Tcl 8.6.1 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index 9b3c298..06ff7a4 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 1a9bb31..61ad30f 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index 27f7189..678222c 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6.0 +Version: 8.6.1 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index fc453f8..e7c1329 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index 373cfcc..6e1af50 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From 0576e11ae0dee27fb806110d84024c8aff28f941 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 1 Sep 2013 20:08:50 +0000 Subject: [b98fa55285]: Fix handling of whitespace at end of hex strings to decode. --- ChangeLog | 6 ++++++ generic/tclBinary.c | 43 +++++++++++++++++++++++-------------------- tests/binary.test | 28 ++++++++++++++++++++++++++++ 3 files changed, 57 insertions(+), 20 deletions(-) diff --git a/ChangeLog b/ChangeLog index ddde893..e0b623b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2013-09-01 Donal Fellows + + * generic/tclBinary.c (BinaryDecodeHex): [Bug b98fa55285]: Ensure that + whitespace at the end of a string don't cause the decoder to drop the + last decoded byte. + 2013-08-03 Donal Fellows * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 901237b..7625d39 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2386,29 +2386,32 @@ BinaryDecodeHex( while (data < dataend) { value = 0; for (i=0 ; i<2 ; i++) { - if (data < dataend) { - c = *data++; - - if (!isxdigit((int) c)) { - if (strict || !isspace(c)) { - goto badChar; - } - i--; - continue; - } + if (data >= dataend) { value <<= 4; - c -= '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); + break; + } + + c = *data++; + if (!isxdigit((int) c)) { + if (strict || !isspace(c)) { + goto badChar; } - value |= (c & 0xf); - } else { - value <<= 4; - cut++; + i--; + continue; } + + value <<= 4; + c -= '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= (c & 0xf); + } + if (i < 2) { + cut++; } *cursor++ = UCHAR(value); value = 0; diff --git a/tests/binary.test b/tests/binary.test index 4393245..d424837 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2499,6 +2499,34 @@ test binary-71.9 {binary decode hex} -body { test binary-71.10 {binary decode hex} -body { string length [binary decode hex " "] } -result 0 +test binary-71.11 {binary decode hex: Bug b98fa55285} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {29 38} +test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} test binary-72.1 {binary encode base64} -body { binary encode base64 -- cgit v0.12 From 5441277b9a31d73e4d91383584882c9303e5c758 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 2 Sep 2013 14:01:00 +0000 Subject: typo --- tests/zlib.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/zlib.test b/tests/zlib.test index c469eea..2ea185f 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -233,7 +233,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" -test zlib-8.8 {transformtion and fconfigure} -setup { +test zlib-8.8 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict @@ -250,7 +250,7 @@ test zlib-8.8 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} -test zlib-8.9 {transformtion and fconfigure} -setup { +test zlib-8.9 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream decompress] } -constraints zlib -body { @@ -267,7 +267,7 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {3064818174 358 358} -test zlib-8.10 {transformtion and fconfigure} -setup { +test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict @@ -284,7 +284,7 @@ test zlib-8.10 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {254 212 {data error} {TCL ZLIB DATA}} -test zlib-8.11 {transformtion and fconfigure} -setup { +test zlib-8.11 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream inflate] } -constraints zlib -body { @@ -300,7 +300,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.12 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -317,7 +317,7 @@ test zlib-8.12 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.13 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -334,7 +334,7 @@ test zlib-8.13 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.14 {transformtion and fconfigure} -setup { +test zlib-8.14 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { @@ -350,7 +350,7 @@ test zlib-8.14 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.15 {transformtion and fconfigure} -setup { +test zlib-8.15 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { -- cgit v0.12 From a01e0439ec88f4f83820d36da9ed018cc3b9ff00 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 2 Sep 2013 17:59:42 +0000 Subject: [010f4162ef] First step of fix on stammering errorstack. errorstack fixed. errorinfo revision still under consideration. --- generic/tclBasic.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 884b5cc..e909a1a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4679,6 +4679,9 @@ TEOV_RunEnterTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + iPtr->flags |= ERR_ALREADY_LOGGED; + } return traceCode; } if (cmdEpoch != newEpoch) { @@ -4725,6 +4728,9 @@ TEOV_RunLeaveTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + iPtr->flags |= ERR_ALREADY_LOGGED; + } return traceCode; } return result; -- cgit v0.12 From bfee748b41a556c2c213d22b99ce12b156acb1d8 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 2 Sep 2013 18:47:07 +0000 Subject: Add test and improve errorInfo. --- generic/tclBasic.c | 22 ++++++++++++++++------ tests/error.test | 10 ++++++++++ 2 files changed, 26 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e909a1a..a10a11a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4680,6 +4680,12 @@ TEOV_RunEnterTraces( if (traceCode != TCL_OK) { if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (enter trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); iPtr->flags |= ERR_ALREADY_LOGGED; } return traceCode; @@ -4702,12 +4708,10 @@ TEOV_RunLeaveTraces( Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; Tcl_Obj **objv = data[3]; - + int length; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - int length; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); @@ -4717,7 +4721,6 @@ TEOV_RunLeaveTraces( cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } } - Tcl_DecrRefCount(commandPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. @@ -4729,10 +4732,17 @@ TEOV_RunLeaveTraces( if (traceCode != TCL_OK) { if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (leave trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); iPtr->flags |= ERR_ALREADY_LOGGED; } - return traceCode; + result = traceCode; } + Tcl_DecrRefCount(commandPtr); return result; } diff --git a/tests/error.test b/tests/error.test index 06f8eca..0de644c 100644 --- a/tests/error.test +++ b/tests/error.test @@ -182,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body { catch {f 12} m d dict get $d -errorstack } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} +test error-4.8 {errorstack from exec traces} -body { + proc foo args {} + proc goo {} foo + trace add execution foo enter {error bar;#} + catch goo m d + dict get $d -errorstack +} -cleanup { + rename goo {}; rename foo {} + unset -nocomplain m d +} -result {INNER {error bar} CALL goo UP 1} # Errors in error command itself -- cgit v0.12 From 9ff2704ae65ba49830398d9835492af591a7a0f3 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:04:06 +0000 Subject: some missed changes --- changes | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/changes b/changes index 2221400..ba7ce74 100644 --- a/changes +++ b/changes @@ -7768,7 +7768,9 @@ Many revisions to better support a Cygwin environment (nijtmans) 2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) -2013-06-27 (bug fix)[32afa6] corrected dirent64 check (griffin) +2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang) + +2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin) 2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) @@ -7778,6 +7780,8 @@ Many revisions to better support a Cygwin environment (nijtmans) 2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) +2013-08-14 (bug fix)[a16752] Missing command delete callbacks (porter) + 2013-08-15 Errors from execution traces become errors of the command (porter) --- Released 8.5.15, September 16, 2013 --- See ChangeLog for details --- -- cgit v0.12 From 05fa6e93c1f1952c259e23fca85fe2cae122ad47 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:04:30 +0000 Subject: update changes --- changes | 128 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 127 insertions(+), 1 deletion(-) diff --git a/changes b/changes index d3bbb43..0339919 100644 --- a/changes +++ b/changes @@ -8164,6 +8164,132 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) --- Released 8.6.0, December 20, 2012 --- See ChangeLog for details --- -2013-05-08 (bug fix)[3036566] Honor language packs on Vista+ to get initial locale (oehlmann) +2012-12-22 (bug fix)[3598150] DString to Tcl_Obj memleak (afredd) + +2012-12-27 (bug fix)[3598580] Tcl_ListObjReplace() refcount fix (nijtmans) + +2013-01-04 (bug fix) memleak in [format] compiler (fellows) + +2013-01-08 (bug fix)[3092089,3587096] [file normalize] on junction points + +2013-01-09 (bug fix)[3599395] status line processing (nijtmans) +2013-01-23 (bug fix)[2911139] repair async connection management (fellows) +=> http 2.8.6 + +2013-01-26 (bug fix)[3601804] Darwin segfault platformCPUID (nijtmans) + +2013-01-28 (enhancement) improve ensemble bytecode (fellows) + +2013-01-30 (enhancement) selected script code improvements (fradin) +=> tcltest 2.3.6 + +2013-01-30 (bug fix)[3599098] update to handle glibc banner changes (kupries) +=> platform 1.0.11 + +2013-01-31 (bug fix)[3598282] make install DESTDIR support (cassoff) + +2013-02-05 (bug fix)[3603434] [file normalize a:/] flaw in VFS (porter,griffin) + +2013-02-09 (bug fix)[3603695] $obj varname resolution rules (venable,fellows) + +2013-02-11 (bug fix)[3603553] zlib flushing errors (vampiera,fellows) + +2013-02-14 (bug fix)[3604576] msgcat use of Windows registry (oehlmann,nijtmans) +=> msgcat 1.5.1 + +2013-02-19 (bug fix)[2438181] report errors in trace handlers (yorick) + +2013-02-21 (bug fix)[3605447] unbreak [namespace export -clear] (porter) + +2013-02-23 (bug fix)[3599194] fallback IPv6 routines (afredd,max) + +2013-02-27 (bug fix)[3606139] stop crash in [regexp] (lane) + +2013-03-03 (bug fix)[3606258] major serial port update (english) + +2013-03-06 (bug fix)[3606683] [regexp (((((a)*)*)*)*)* {}] hangs +(grathwohl,lane,porter) + +2013-03-12 (enhancement) better build support for Debian arch (shadura) + +2013-03-19 (bug fix)[2893771] [file stat] on locked files (thoyts,nijtmans) + +2013-03-21 (bug fix)[2102614] [auto_mkindex] ensemble support (griffin) + +2013-03-27 Tcl_Zlib*() routines tolerate NULL interps (porter + +2013-04-04 (bug fix) Support URLs with query but no path (max) +=> http 2.8.7 + +2013-04-08 (bug fix)[3610026] regexp crash on color overflow (linnakangas) + +2013-04-29 (enhancement) [array set] compile improvement (fellows) + +2013-04-30 (enhancement) broaden glibc version detection (kupries) +=> platform 1.0.12 + +2013-05-06 (platform support) Cygwin64 (nijtmans) + +2013-05-15 (enhancement) Improved [list {*}...] compile (fellows) + +2013-05-16 (platform support) mingw-4.0 (nijtmans) + +2013-05-19 (platform support) FreeBSD updates (cerutti) + +2013-05-20 (bug fix)[3613567] access error temp file creation (keene) + +2013-05-20 (bug fix)[3613569] temp file open fail can crash [load] (keene) + +2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows) + +2013-05-28 (bug fix)[3036566] Use language packs (Vista+) locale (oehlmann) => msgcat 1.5.2 +2013-05-29 (bug fix)[3614102] [apply {{} {list [if 1]}}] stack woes (porter) + +2013-06-03 Restored lost performance appending to long strings (elby,porter) + +2013-06-05 (bug fix)[2835313] [while 1 {foo [continue]}] crash (fellows) + +2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans) + +2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) + +2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang) + +2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin) + +2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) + +2013-07-10 (bug fix)[86fb5e] [info frame] in compiled ensembles (porter) + +2013-07-18 (bug fix)[1c17fb] revisd syntax errorinfo that shows error (porter) + +2013-07-26 (bug fix)[6585b2] regexp {(\w).*?\1} abb (lane) + +2013-07-29 [string is space \u202f] => 1 (nijtmans) + +2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) + +2013-08-01 (bug fix)[1905562] RE recursion limit increased to support +reported usage of large expressions (porter) + +2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows)2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows) + +2013-08-03 (enhancement)[3611643] [auto_mkindex] support TclOO (fellows) + +2013-08-14 (bug fix)[a16752] Missing command delete callbacks (porter) + +2013-08-15 (bug fix)[3610404] reresolve traced forwards (porter) + +2013-08-15 Errors from execution traces become errors of the command (porter) + +2013-08-23 (bug fix)[8ff0cb9] Tcl_NR*Eval*() schedule only, as doc'd (porter) + +2013-08-29 (bug fix)[2486550] enable [interp invokehidden {} yield] (porter) + +2013-09-01 (bug fix)[b98fa55] [binary decode] fail on whitespace (reche,fellows) + +Many optmizations, improvements, and tightened stack management in bytecode. + +--- Released 8.6.1, Septemer 18, 2013 --- See ChangeLog for details --- -- cgit v0.12 From 89d7d04dbc30e04aabc39806f925f51a835889fd Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:45:56 +0000 Subject: Favor timeline over ChangeLog --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index ba7ce74..c51ff93 100644 --- a/changes +++ b/changes @@ -7784,4 +7784,4 @@ Many revisions to better support a Cygwin environment (nijtmans) 2013-08-15 Errors from execution traces become errors of the command (porter) ---- Released 8.5.15, September 16, 2013 --- See ChangeLog for details --- +--- Released 8.5.15, September 16, 2013 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From 8bc4ab1c8756c1abaefa435e76d7a4ab6458bdb9 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:47:50 +0000 Subject: Favor timeline over ChangeLog --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index 0339919..5428c3e 100644 --- a/changes +++ b/changes @@ -8292,4 +8292,4 @@ reported usage of large expressions (porter) Many optmizations, improvements, and tightened stack management in bytecode. ---- Released 8.6.1, Septemer 18, 2013 --- See ChangeLog for details --- +--- Released 8.6.1, Septemer 18, 2013 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From da0f4e22533c85ac4c70e6a45cb88cd87176cb66 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 17:07:41 +0000 Subject: typo --- pkgs/README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/README b/pkgs/README index 01c6f43..868bd4f 100644 --- a/pkgs/README +++ b/pkgs/README @@ -39,7 +39,7 @@ needs to conform to the following conventions. distclean: Delete all generated files. dist: Produce a copy of the package's source code distribution. - Must respect the DIST_ROOT variable determing where to + Must respect the DIST_ROOT variable determining where to write the generated directory. Packages that are written to make use of the Tcl Extension Architecture (TEA) -- cgit v0.12 From a7ced6a9fdfa214f263e10b93d9d93b4f22d739d Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 17:39:34 +0000 Subject: make dist --- unix/tclConfig.h.in | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 23d6026..e55dcd0 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -115,6 +115,9 @@ /* Define to 1 if you have the `gmtime_r' function. */ #undef HAVE_GMTIME_R +/* Compiler support for module scope symbols */ +#undef HAVE_HIDDEN + /* Do we have the intptr_t type? */ #undef HAVE_INTPTR_T @@ -343,9 +346,6 @@ /* Do we have ? */ #undef NO_VALUES_H -/* Compiler support for module scope symbols */ -#undef HAVE_HIDDEN - /* Do we have wait3() */ #undef NO_WAIT3 -- cgit v0.12 From ee5dada68d84581a9b0c3ac970c11b862f0eb186 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 18:50:08 +0000 Subject: doc fix exposed by `make html` --- doc/file.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/file.n b/doc/file.n index 0b0ee9d..c117ee1 100644 --- a/doc/file.n +++ b/doc/file.n @@ -484,7 +484,7 @@ not the effective ones. .TP \fBWindows\fR\0\0\0\0 . -The \fbfile owned\fR subcommand currently always reports that the current user +The \fBfile owned\fR subcommand currently always reports that the current user is the owner of the file, without regard for what the operating system believes to be true, making an ownership test useless. This issue (#3613671) may be fixed in a future release of Tcl. -- cgit v0.12 From 5e237c28521e9a2146369913d30a10b2712b9fc2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Sep 2013 07:22:45 +0000 Subject: Fix 3 trivial (possible) errors, discovered by covertity.com --- generic/tclUtil.c | 3 +-- unix/tclUnixFCmd.c | 4 ++-- unix/tclUnixSock.c | 2 ++ 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 27e2474..b089132 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3580,10 +3580,9 @@ UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + 5]; - register int len; + register int len = 3; memcpy(buffer, "end", 4); - len = sizeof("end") - 1; if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index e27f78f..e270b6a 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -462,10 +462,10 @@ DoCopyFile( switch ((int) (statBufPtr->st_mode & S_IFMT)) { #ifndef DJGPP case S_IFLNK: { - char linkBuf[MAXPATHLEN]; + char linkBuf[MAXPATHLEN+1]; int length; - length = readlink(src, linkBuf, sizeof(linkBuf)); + length = readlink(src, linkBuf, MAXPATHLEN); /* INTL: Native. */ if (length == -1) { return TCL_ERROR; diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 9c3d7eb..a6360c2 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1358,6 +1358,7 @@ Tcl_OpenTcpServer( my_errno = errno; } close(sock); + sock = -1; continue; } if (port == 0 && chosenport == 0) { @@ -1380,6 +1381,7 @@ Tcl_OpenTcpServer( my_errno = errno; } close(sock); + sock = -1; continue; } if (statePtr == NULL) { -- cgit v0.12 From f16149f5a641a30843d2bb4e3dd2734e50ecbe14 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 4 Sep 2013 09:36:22 +0000 Subject: [98c8b3ec12] Make test fail in less catastrophic manner. --- tests/zlib.test | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tests/zlib.test b/tests/zlib.test index 2ea185f..0712929 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -276,7 +276,10 @@ test zlib-8.10 {transformation and fconfigure} -setup { puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] - catch {zlib inflate $compressed} err opt + catch { + zlib inflate $compressed + throw UNREACHABLE "should be unreachable" + } err opt list [string length [zlib deflate $spdyHeaders]] \ [string length $compressed] \ $err [dict get $opt -errorcode] -- cgit v0.12 From 0a973a55fed4b9cba1558fc7c93d412665f7063c Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 4 Sep 2013 12:45:51 +0000 Subject: Cleaned up test command trying to make valgrind happy. --- generic/tclTest.c | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 96973d7..f121d0d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4408,8 +4408,26 @@ TestseterrorcodeCmd( Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + switch (argc) { + case 1: + Tcl_SetErrorCode(interp, "NONE", NULL); + break; + case 2: + Tcl_SetErrorCode(interp, argv[1], NULL); + break; + case 3: + Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + break; + case 4: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + break; + case 5: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + break; + case 6: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); + } return TCL_ERROR; } -- cgit v0.12 From 133768540d48de8f9bf0638fd9983178588bd18a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 12:45:11 +0000 Subject: Error in order of #include lines broke some windows builds. --- generic/tclParse.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index c5cb1d1..ee0d4c4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -13,9 +13,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include #include "tclInt.h" #include "tclParse.h" +#include /* * The following table provides parsing information about each possible 8-bit -- cgit v0.12 From 4bba36ca59c3760f9e2a593e8135aa6f8352919e Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 15:47:29 +0000 Subject: Use ne instead of [string length] for less shimmer risk. --- library/tm.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/tm.tcl b/library/tm.tcl index 955e84d..55efda6 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,7 +238,7 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } - if {[string length [package ifneeded $pkgname $pkgversion]]} { + if {[package ifneeded $pkgname $pkgversion] ne {}} { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same -- cgit v0.12 From 76023565adb6e64816efbf4cae39b1c5d2ab725a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 17:21:41 +0000 Subject: Partial revert of [a16752c252] bug fix to stop crashes in buggy tclcompiler. --- generic/tclBasic.c | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 314b5fc..c3ab871 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1967,7 +1967,8 @@ Tcl_CreateCommand( * * Side effects: * If a command named "cmdName" already exists for interp, it is - * first deleted. Then the new command is created from the arguments. + * first deleted. Then the new command is created from the arguments. + * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2034,8 +2035,27 @@ Tcl_CreateObjCommand( if (!isNew) { cmdPtr = Tcl_GetHashValue(hPtr); + /* Command already exists. */ + + /* + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular + * circumstances to accommodate deployed binaries of the + * "tclcompiler" program. http://sourceforge.net/projects/tclpro/ + * that crash if the bug is fixed. + */ + + if (cmdPtr->objProc == TclInvokeStringCommand + && cmdPtr->clientData == clientData + && cmdPtr->deleteData == clientData + && cmdPtr->deleteProc == deleteProc) { + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + return (Tcl_Command) cmdPtr; + } + /* - * Command already exists; delete it. Be careful to preserve any + * Otherwise, we delete the old command. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. -- cgit v0.12 From 991ddbd26c7c24de6598ff9fe61a1d9f13186548 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 8 Sep 2013 10:21:37 +0000 Subject: [3611643] Stop polluting the global namespace. Refactor the index entry generation so it is done right, once. Handle more of [namespace ensemble create]'s behavior. --- library/auto.tcl | 69 +++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 43 insertions(+), 26 deletions(-) diff --git a/library/auto.tcl b/library/auto.tcl index 78c219e..02edcc4 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -513,6 +513,32 @@ proc auto_mkindex_parser::fullname {name} { return [string map [list \0 \$] $name] } +# auto_mkindex_parser::indexEntry -- +# +# Used by commands like "proc" within the auto_mkindex parser to add a +# correctly-quoted entry to the index. This is shared code so it is done +# *right*, in one place. +# +# Arguments: +# name - Name that is being added to index. + +proc auto_mkindex_parser::indexEntry {name} { + variable index + variable scriptFile + + # We convert all metacharacters to their backslashed form, and pre-split + # the file name that we know about (which will be a proper list, and so + # correctly quoted). + + set name [string range [list \}[fullname $name]] 2 end] + set filenameParts [file split $scriptFile] + + append index [format \ + {set auto_index(%s) [list source [file join $dir %s]]%s} \ + $name $filenameParts \n] + return +} + if {[llength $::auto_mkindex_parser::initCommands]} { return } @@ -524,15 +550,7 @@ if {[llength $::auto_mkindex_parser::initCommands]} { # Adds an entry to the auto index list for the given procedure name. auto_mkindex_parser::command proc {name args} { - variable index - variable scriptFile - # Do some fancy reformatting on the "source" call to handle platform - # differences with respect to pathnames. Use format just so that the - # command is a little easier to read (otherwise it'd be full of - # backslashed dollar signs, etc. - append index [list set auto_index([fullname $name])] \ - [format { [list source [file join $dir %s]]} \ - [file split $scriptFile]] "\n" + indexEntry $name } # Conditionally add support for Tcl byte code files. There are some tricky @@ -559,14 +577,7 @@ auto_mkindex_parser::hook { # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { - variable index - variable scriptFile - # Do some nice reformatting of the "source" call, to get around - # path differences on different platforms. We use the format - # command just so that the code is a little easier to read. - append index [list set auto_index([fullname $name])] \ - [format { [list source [file join $dir %s]]} \ - [file split $scriptFile]] "\n" + indexEntry $name } } } @@ -610,6 +621,13 @@ auto_mkindex_parser::command namespace {op args} { variable contextStack if {[lindex $args 0] eq "create"} { set name ::[join [lreverse $contextStack] ::] + catch { + set name [dict get [lrange $args 1 end] -command] + if {![string match ::* $name]} { + set name ::[join [lreverse $contextStack] ::]$name + } + regsub -all ::+ $name :: name + } # create artifical proc to force an entry in the tclIndex $parser eval [list ::proc $name {} {}] } @@ -619,15 +637,14 @@ auto_mkindex_parser::command namespace {op args} { # AUTO MKINDEX: oo::class create name ?definition? # Adds an entry to the auto index list for the given class name. -foreach cmd {oo::class class} { - auto_mkindex_parser::command $cmd {ecmd name {body ""}} { - if {$cmd eq "create"} { - variable index - variable scriptFile - append index [format "set %s \[list source \[%s]]\n" \ - [list auto_index([fullname $name])] \ - [list file join $dir {*}[file split $scriptFile]]] - } +auto_mkindex_parser::command oo::class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name + } +} +auto_mkindex_parser::command class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name } } -- cgit v0.12 From 6652de82ba5502a042b2be29a5cf7e04b73fca4b Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 9 Sep 2013 13:34:06 +0000 Subject: [3609693] Must strip the internal representation of procedure-like methods in order to ensure that any bound references to instance variables are removed. --- generic/tclOOMethod.c | 50 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 48 insertions(+), 2 deletions(-) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 81293c7..61215de 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1290,11 +1290,57 @@ CloneProcedureMethod( ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; - ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod)); + ProcedureMethod *pm2Ptr; + Tcl_Obj *bodyObj, *argsObj; + CompiledLocal *localPtr; + /* + * Copy the argument list. + */ + + argsObj = Tcl_NewObj(); + for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj = Tcl_NewObj(); + + Tcl_ListObjAppendElement(NULL, argObj, + Tcl_NewStringObj(localPtr->name, -1)); + if (localPtr->defValuePtr != NULL) { + Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); + } + Tcl_ListObjAppendElement(NULL, argsObj, argObj); + } + } + + /* + * Must strip the internal representation in order to ensure that any + * bound references to instance variables are removed. [Bug 3609693] + */ + + bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); + TclFreeIntRep(bodyObj); + + /* + * Create the actual copy of the method record, manufacturing a new proc + * record. + */ + + pm2Ptr = ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; - pm2Ptr->procPtr->refCount++; + Tcl_IncrRefCount(argsObj); + Tcl_IncrRefCount(bodyObj); + if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, + &pm2Ptr->procPtr) != TCL_OK) { + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + ckfree(pm2Ptr); + return TCL_ERROR; + } + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + if (pmPtr->cloneClientdataProc) { pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData); } -- cgit v0.12 From 28bb618586416fbb3c1c9a710cf88e5f8d924025 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 02:32:04 +0000 Subject: Stop the save and restore of currStackDepth. Just manage it correctly so it doesn't need correcting. --- generic/tclCompExpr.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 2a48117..c2b5a1a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,8 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int depth; /* Remember the currStackDepth of the - * CompileEnv here. */ int offset; /* Data used to compute jump lengths to pass * to TclFixupForwardJump() */ int convert; /* Temporary storage used to compute whether @@ -2269,7 +2267,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; convert = 1; break; case AND: @@ -2283,7 +2280,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; break; } } else if (nodePtr->mark == MARK_RIGHT) { @@ -2323,7 +2319,7 @@ CompileExprTree( CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); - envPtr->currStackDepth = jumpPtr->depth; + TclAdjustStackDepth(-1, envPtr); jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; @@ -2383,7 +2379,6 @@ CompileExprTree( TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->offset - jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2411,7 +2406,6 @@ CompileExprTree( TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, 127); convert = 0; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From 7eabd2838a8210a30da24672179294fd7d8b1b0a Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 04:49:08 +0000 Subject: Make use of the existing JumpFixup fields. Eliminate extra storage field 'offset' in JumpList that we don't require. --- generic/tclCompExpr.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index c2b5a1a..0021323 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,8 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int offset; /* Data used to compute jump lengths to pass - * to TclFixupForwardJump() */ int convert; /* Temporary storage used to compute whether * numeric conversion will be needed following * the operator we're compiling. */ @@ -2320,7 +2318,6 @@ CompileExprTree( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); TclAdjustStackDepth(-1, envPtr); - jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; break; @@ -2374,10 +2371,10 @@ CompileExprTree( if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->offset += 3; + jumpPtr->next->jump.codeOffset += 3; } TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->offset - jumpPtr->jump.codeOffset, 127); + jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; freePtr = jumpPtr; jumpPtr = jumpPtr->next; -- cgit v0.12 From 23bb5a2c20bd07e4b66ad4293fb927128e9e975b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 05:07:52 +0000 Subject: Eliminate another surplus storage field. Make a(n ab)use of the existing JumpFixup fields instead. --- generic/tclCompExpr.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 0021323..4afb069 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,9 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int convert; /* Temporary storage used to compute whether - * numeric conversion will be needed following - * the operator we're compiling. */ struct JumpList *next; /* Point to next item on the stack */ } JumpList; @@ -2318,7 +2315,9 @@ CompileExprTree( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); TclAdjustStackDepth(-1, envPtr); - jumpPtr->convert = convert; + if (convert) { + jumpPtr->jump.jumpType = TCL_TRUE_JUMP; + } convert = 1; break; case AND: @@ -2368,6 +2367,10 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); + if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { + jumpPtr->jump.jumpType = TCL_FALSE_JUMP; + convert = 1; + } if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { @@ -2375,7 +2378,6 @@ CompileExprTree( } TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); - convert |= jumpPtr->convert; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From 3e3fe2606ae5233ae213b95fd91d7d05d2987659 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 17:42:36 +0000 Subject: Stop allocating JumpFixups for jumps that can never need any fixing up. --- generic/tclCompExpr.c | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 4afb069..7684c70 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2269,12 +2269,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; break; } } else if (nodePtr->mark == MARK_RIGHT) { @@ -2328,6 +2322,8 @@ CompileExprTree( break; } } else { + int pc1, pc2; + switch (nodePtr->lexeme) { case START: case QUESTION: @@ -2377,7 +2373,9 @@ CompileExprTree( jumpPtr->next->jump.codeOffset += 3; } TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); + jumpPtr->next->jump.codeOffset + 2 + - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2388,32 +2386,27 @@ CompileExprTree( case AND: case OR: CLANG_ASSERT(jumpPtr); - TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) - ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, - &jumpPtr->next->jump); + pc1 = CurrentOffset(envPtr); + TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 + : INST_JUMP_TRUE1, 0, envPtr); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->next->jump); + pc2 = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, + envPtr->codeStart + pc1 + 1); if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - jumpPtr->next->next->jump.codeOffset += 3; + pc2 += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, - 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, + envPtr->codeStart + pc2 + 1); convert = 0; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); break; default: TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); -- cgit v0.12 From c12159563db8f0ecce0a00351e1cb0caed2a7acc Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 19:21:20 +0000 Subject: Swap the two fixups used when compiling the ternary operator. Push them on the stack only when needed, and pop as soon as possible. --- generic/tclCompExpr.c | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 7684c70..106855a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2256,12 +2256,6 @@ CompileExprTree( switch (nodePtr->lexeme) { case QUESTION: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; convert = 1; break; case AND: @@ -2302,12 +2296,17 @@ CompileExprTree( break; } case QUESTION: + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: - CLANG_ASSERT(jumpPtr); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->jump); + &jumpPtr->jump); TclAdjustStackDepth(-1, envPtr); if (convert) { jumpPtr->jump.jumpType = TCL_TRUE_JUMP; @@ -2322,7 +2321,7 @@ CompileExprTree( break; } } else { - int pc1, pc2; + int pc1, pc2, target; switch (nodePtr->lexeme) { case START: @@ -2364,21 +2363,21 @@ CompileExprTree( case COLON: CLANG_ASSERT(jumpPtr); if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { - jumpPtr->jump.jumpType = TCL_FALSE_JUMP; + jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; convert = 1; } - if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, + target = jumpPtr->jump.codeOffset + 2; + if (TclFixupForwardJump(envPtr, &jumpPtr->jump, (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->next->jump.codeOffset += 3; + - jumpPtr->jump.codeOffset, 127)) { + target += 3; } - TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->next->jump.codeOffset + 2 - - jumpPtr->jump.codeOffset, 127); - freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); + TclFixupForwardJump(envPtr, &jumpPtr->jump, + target - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From c34e729136c3608344a630fc086235da2a4092e4 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 19:27:48 +0000 Subject: Push fixup on the stack only when needed. --- generic/tclCompExpr.c | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 106855a..fce870b 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2254,16 +2254,8 @@ CompileExprTree( if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; - switch (nodePtr->lexeme) { - case QUESTION: + if (nodePtr->lexeme == QUESTION) { convert = 1; - break; - case AND: - case OR: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - break; } } else if (nodePtr->mark == MARK_RIGHT) { next = nodePtr->right; @@ -2314,10 +2306,12 @@ CompileExprTree( convert = 1; break; case AND: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); - break; case OR: - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { -- cgit v0.12 From 6fef99593ff6cf1e4f504ca2a9ddabbd0d17c04b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Sep 2013 03:33:43 +0000 Subject: More macro use. --- generic/tclCompCmds.c | 8 ++------ generic/tclCompExpr.c | 4 +--- 2 files changed, 3 insertions(+), 9 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 8edb2d9..fdc8ec1 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2228,7 +2228,7 @@ TclCompileForCmd( { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; + int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; DefineLineInformation; /* TIP #280 */ @@ -2309,13 +2309,9 @@ TclCompileForCmd( * terminates the for. */ - testCodeOffset = CurrentOffset(envPtr); - - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; - testCodeOffset += 3; } SetLineInformation(2); diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index fce870b..d8e4d9f 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2361,9 +2361,7 @@ CompileExprTree( convert = 1; } target = jumpPtr->jump.codeOffset + 2; - if (TclFixupForwardJump(envPtr, &jumpPtr->jump, - (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->jump.codeOffset, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { target += 3; } freePtr = jumpPtr; -- cgit v0.12 From 878be345c1b4a3fbf9756a06985a1b2ce306bd57 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 13 Sep 2013 10:53:32 +0000 Subject: Suggested fix for [bdd91c7e43]: tclsh crashes in [interp delete] --- generic/tclExecute.c | 1 + unix/configure | 0 2 files changed, 1 insertion(+) mode change 100755 => 100644 unix/configure diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8fb8e63..e657828 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2311,6 +2311,7 @@ TclExecuteByteCode( initCatchTop += moved; catchTop += moved; + bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1); initTosPtr += moved; tosPtr += moved; esPtr = iPtr->execEnvPtr->execStackPtr; diff --git a/unix/configure b/unix/configure old mode 100755 new mode 100644 -- cgit v0.12 From 55f663e53f501bf7c9748ad6a70d148b41a83b2b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Sep 2013 16:02:11 +0000 Subject: Added note to ChangeLog pointing to the fossil timeline for better logging. --- ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/ChangeLog b/ChangeLog index fca182b..fd8c7c7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +A NOTE ON THE CHANGELOG: +Starting in early 2011, Tcl source code has been under the management of +fossil, hosted at http://core.tcl.tk/tcl/ . Fossil presents a "Timeline" +view of changes made that is superior in every way to a hand edited log file. +Because of this, many Tcl developers are now out of the habit of maintaining +this log file. You may still find useful things in it, but the Timeline is +a better first place to look now. +============================================================================ + 2013-08-30 Don Porter * generic/tcl.h: Bump to 8.5.15 for release. -- cgit v0.12 From 92eea63a7df5071fddef9b89b9122a5761670908 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 14 Sep 2013 07:07:03 +0000 Subject: [2152292] Corrected implementation of uuencoding. --- doc/binary.n | 17 +++---- generic/tclBinary.c | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++-- tests/binary.test | 43 ++++++++++++------ 3 files changed, 158 insertions(+), 27 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index a40afe6..95be36e 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -96,25 +96,22 @@ largely superseded by the \fBbase64\fR binary encoding. .RS .PP During encoding, the following options are supported: -'\" This is wrong! The uuencode format had more complexity than this! .TP \fB\-maxlen \fIlength\fR . Indicates that the output should be split into lines of no more than -\fIlength\fR characters. By default, lines are not split. -.TP -\fB\-wrapchar \fIcharacter\fR -. -Indicates that, when lines are split because of the \fB\-maxlen\fR option, -\fIcharacter\fR should be used to separate lines. By default, this is a -newline character, -.QW \en . +\fIlength\fR characters. By default, lines are split every 61 characters, and +this must be in the range 3 to 85 due to limitations in the encoding. .PP During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters whitespace characters. Otherwise it ignores them. +Instructs the decoder to throw an error if it encounters whitespace +characters. Otherwise it ignores them. +.PP +Note that neither the encoder nor the decoder handle the header and footer of +the uuencode format. .RE .VE 8.6 .SH "BINARY FORMAT" diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 7625d39..71da309 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -87,10 +87,13 @@ static int BinaryDecodeHex(ClientData clientData, static int BinaryEncode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecodeUu(ClientData clientData, +static int BinaryDecode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecode64(ClientData clientData, +static int BinaryEncodeUu(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int BinaryDecodeUu(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -140,7 +143,7 @@ static const EnsembleImplMap binaryMap[] = { }; static const EnsembleImplMap encodeMap[] = { { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, - { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, + { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; @@ -2439,7 +2442,7 @@ BinaryDecodeHex( * This implements a generic 6 bit binary encoding. Input is broken into * 6 bit chunks and a lookup table passed in via clientData is used to * turn these values into output characters. This is used to implement - * base64 and uuencode binary encodings. + * base64 binary encodings. * * Results: * Interp result set to an encoded byte array object @@ -2498,6 +2501,12 @@ BinaryEncode64( if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) { return TCL_ERROR; } + if (maxlen < 0) { + Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); @@ -2550,6 +2559,114 @@ BinaryEncode64( /* *---------------------------------------------------------------------- * + * BinaryEncodeUu -- + * + * This implements the uuencode binary encoding. Input is broken into 6 + * bit chunks and a lookup table is used to turn these values into output + * characters. This differs from the generic code above in that line + * lengths are also encoded. + * + * Results: + * Interp result set to an encoded byte array object + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static int +BinaryEncodeUu( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *resultObj; + unsigned char *data, *start, *cursor; + int offset, count, rawLength, n, i, bits, index; + int lineLength = 61; + enum {OPT_MAXLEN}; + static const char *const optStrings[] = { "-maxlen", NULL }; + + if (objc < 2 || objc%2 != 0) { + Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? data"); + return TCL_ERROR; + } + for (i = 1; i < objc-1; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case OPT_MAXLEN: + if (Tcl_GetIntFromObj(interp, objv[i+1], &lineLength) != TCL_OK) { + return TCL_ERROR; + } + if (lineLength < 3 || lineLength > 85) { + Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } + break; + } + } + + /* + * Allocate the buffer. This is a little bit too long, but is "good + * enough". + */ + + resultObj = Tcl_NewObj(); + offset = 0; + data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); + rawLength = (lineLength - 1) * 3 / 4; + start = cursor = Tcl_SetByteArrayLength(resultObj, + (lineLength + 1) * ((count + (rawLength - 1)) / rawLength)); + n = bits = 0; + + /* + * Encode the data. Each output line first has the length of raw data + * encoded by the output line described in it by one encoded byte, then + * the encoded data follows (encoding each 6 bits as one character). + * Encoded lines are always terminated by a newline. + */ + + while (offset < count) { + int lineLen = count - offset; + + if (lineLen > rawLength) { + lineLen = rawLength; + } + *cursor++ = UueDigits[lineLen]; + for (i=0 ; i 6 ; bits -= 6) { + *cursor++ = UueDigits[(n >> (bits-6)) & 0x3f]; + } + } + if (bits > 0) { + n <<= 8; + *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; + bits = 0; + } + *cursor++ = '\n'; + } + + /* + * Fix the length of the output bytearray. + */ + + Tcl_SetByteArrayLength(resultObj, cursor-start); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * BinaryDecodeUu -- * * Decode a uuencoded string. diff --git a/tests/binary.test b/tests/binary.test index d424837..4b71b77 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2705,34 +2705,51 @@ test binary-74.1 {binary encode uuencode} -body { } -returnCodes error -match glob -result "wrong # args: *" test binary-74.2 {binary encode uuencode} -body { binary encode uuencode abc -} -result {86)C} +} -result {#86)C +} test binary-74.3 {binary encode uuencode} -body { binary encode uuencode {} } -result {} test binary-74.4 {binary encode uuencode} -body { binary encode uuencode [string repeat abc 20] -} -result [string repeat 86)C 20] +} -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" test binary-74.5 {binary encode uuencode} -body { binary encode uuencode \0\1\2\3\4\0\1\2\3 -} -result "``\$\"`P0``0(#" +} -result ")``\$\"`P0``0(#\n" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 -} -result {````} +} -result {!`` +} test binary-74.7 {binary encode uuencode} -body { binary encode uuencode \0\0 -} -result {````} +} -result "\"``` +" test binary-74.8 {binary encode uuencode} -body { binary encode uuencode \0\0\0 -} -result {````} +} -result {#```` +} test binary-74.9 {binary encode uuencode} -body { binary encode uuencode \0\0\0\0 -} -result {````````} -test binary-74.10 {binary encode uuencode} -body { - binary encode uuencode -maxlen 0 -wrapchar | abcabcabc -} -result {86)C86)C86)C} -test binary-74.11 {binary encode uuencode} -body { - binary encode uuencode -maxlen 1 -wrapchar | abcabcabc -} -result {8|6|)|C|8|6|)|C|8|6|)|C} +} -result {$`````` +} +test binary-74.10 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 30 -wrapchar | abcabcabc +} -result {bad option "-wrapchar": must be -maxlen} +test binary-74.11 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 1 abcabcabc +} -result {line length out of range} +test binary-74.12 {binary encode uuencode} -body { + binary encode uuencode -maxlen 3 abcabcabc +} -result {!80 +!8@ +!8P +!80 +!8@ +!8P +!80 +!8@ +!8P +} test binary-75.1 {binary decode uuencode} -body { binary decode uuencode -- cgit v0.12 From b1264cd184de3c9ba370ae1e9cb9bb029b12872b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 14 Sep 2013 08:51:23 +0000 Subject: Add back -wrapchar option to "binary encode uuencode". --- doc/binary.n | 9 ++++++++- generic/tclBinary.c | 25 +++++++++++++++++++------ tests/binary.test | 17 ++++------------- 3 files changed, 31 insertions(+), 20 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 95be36e..9f22fb1 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -64,7 +64,7 @@ Indicates that the output should be split into lines of no more than . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character, +newline character. .QW \en . .PP During decoding, the following options are supported: @@ -102,6 +102,13 @@ During encoding, the following options are supported: Indicates that the output should be split into lines of no more than \fIlength\fR characters. By default, lines are split every 61 characters, and this must be in the range 3 to 85 due to limitations in the encoding. +.TP +\fB\-wrapchar \fIcharacter\fR +. +Indicates that, when lines are split because of the \fB\-maxlen\fR option, +\fIcharacter\fR should be used to separate lines. By default, this is a +newline character. +.QW \en . .PP During decoding, the following options are supported: .TP diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 71da309..98a4d31 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2584,13 +2584,15 @@ BinaryEncodeUu( { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; - int offset, count, rawLength, n, i, bits, index; + int offset, count, rawLength, n, i, j, bits, index; int lineLength = 61; - enum {OPT_MAXLEN}; - static const char *const optStrings[] = { "-maxlen", NULL }; + const char *wrapchar = "\n"; + int wrapcharlen = 1; + enum {OPT_MAXLEN, OPT_WRAPCHAR }; + static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc%2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { @@ -2610,6 +2612,15 @@ BinaryEncodeUu( return TCL_ERROR; } break; + case OPT_WRAPCHAR: + wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + if (wrapcharlen < 0 || wrapcharlen > 2) { + Tcl_SetResult(interp, "wrap char out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "WRAP_CHAR", NULL); + return TCL_ERROR; + } + break; } } @@ -2623,7 +2634,7 @@ BinaryEncodeUu( data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, - (lineLength + 1) * ((count + (rawLength - 1)) / rawLength)); + (lineLength + wrapcharlen) * ((count + (rawLength - 1)) / rawLength)); n = bits = 0; /* @@ -2652,7 +2663,9 @@ BinaryEncodeUu( *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; bits = 0; } - *cursor++ = '\n'; + for (j=0; j Date: Sat, 14 Sep 2013 08:59:41 +0000 Subject: Hm, this check doesn't really add anything. --- generic/tclBinary.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 98a4d31..69f5baf 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2614,12 +2614,6 @@ BinaryEncodeUu( break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); - if (wrapcharlen < 0 || wrapcharlen > 2) { - Tcl_SetResult(interp, "wrap char out of range", TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "WRAP_CHAR", NULL); - return TCL_ERROR; - } break; } } -- cgit v0.12 From 0f1f636a50239c2409172a34da5fa1b1f45bf9c4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 14 Sep 2013 18:25:45 +0000 Subject: And the decoder too. --- doc/binary.n | 2 +- generic/tclBinary.c | 104 +++++++++++++++++++++++++++++++++++++++++++--------- tests/binary.test | 41 +++++++++++---------- 3 files changed, 109 insertions(+), 38 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 95be36e..b301f4d 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -107,7 +107,7 @@ During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters whitespace +Instructs the decoder to throw an error if it encounters unexpected whitespace characters. Otherwise it ignores them. .PP Note that neither the encoder nor the decoder handle the header and footer of diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 71da309..c0dd926 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2690,8 +2690,8 @@ BinaryDecodeUu( Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; - int i, index, size, count = 0, cut = 0, strict = 0; - char c; + int i, index, size, count = 0, strict = 0, lineLen; + unsigned char c; enum {OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; @@ -2717,44 +2717,112 @@ BinaryDecodeUu( dataend = data + count; size = ((count + 3) & ~3) * 3 / 4; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); + lineLen = -1; + + /* + * The decoding loop. First, we get the length of line (strictly, the + * number of data bytes we expect to generate from the line) we're + * processing this time round if it is not already known (i.e., when the + * lineLen variable is set to the magic value, -1). + */ + while (data < dataend) { char d[4] = {0, 0, 0, 0}; + if (lineLen < 0) { + c = *data++; + if (c < 32 || c > 96) { + if (strict || !isspace(c)) { + goto badUu; + } + i--; + continue; + } + lineLen = (c - 32) & 0x3f; + } + + /* + * Now we read a four-character grouping. + */ + for (i=0 ; i<4 ; i++) { if (data < dataend) { d[i] = c = *data++; - if (c < 33 || c > 96) { - if (strict || !isspace(UCHAR(c))) { - goto badUu; + if (c < 32 || c > 96) { + if (strict) { + if (!isspace(c)) { + goto badUu; + } else if (c == '\n') { + goto shortUu; + } } i--; continue; } - } else { - cut++; } } - if (cut > 3) { - cut = 3; + + /* + * Translate that grouping into (up to) three binary bytes output. + */ + + if (lineLen > 0) { + *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) + | (((d[1] - 0x20) & 0x3f) >> 4); + if (--lineLen > 0) { + *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) + | (((d[2] - 0x20) & 0x3f) >> 2); + if (--lineLen > 0) { + *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) + | (((d[3] - 0x20) & 0x3f)); + lineLen--; + } + } + } + + /* + * If we've reached the end of the line, skip until we process a + * newline. + */ + + if (lineLen == 0 && data < dataend) { + lineLen = -1; + do { + c = *data++; + if (c == '\n') { + break; + } else if (c >= 32 && c <= 96) { + data--; + break; + } else if (strict || !isspace(c)) { + goto badUu; + } + } while (data < dataend); } - *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) - | (((d[1] - 0x20) & 0x3f) >> 4); - *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) - | (((d[2] - 0x20) & 0x3f) >> 2); - *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) - | (((d[3] - 0x20) & 0x3f)); } - if (cut > size) { - cut = size; + + /* + * Sanity check, clean up and finish. + */ + + if (lineLen > 0 && strict) { + goto shortUu; } - Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); + Tcl_SetByteArrayLength(resultObj, cursor - begin); Tcl_SetObjResult(interp, resultObj); return TCL_OK; + shortUu: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL); + TclDecrRefCount(resultObj); + return TCL_ERROR; + badUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid uuencode character \"%c\" at position %d", c, (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } diff --git a/tests/binary.test b/tests/binary.test index 4b71b77..607a070 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2755,72 +2755,75 @@ test binary-75.1 {binary decode uuencode} -body { binary decode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-75.2 {binary decode uuencode} -body { - binary decode uuencode 86)C + binary decode uuencode "#86)C\n" } -result {abc} test binary-75.3 {binary decode uuencode} -body { binary decode uuencode {} } -result {} +test binary-75.3.1 {binary decode uuencode} -body { + binary decode uuencode `\n +} -result {} test binary-75.4 {binary decode uuencode} -body { - binary decode uuencode [string repeat "86)C" 20] + binary decode uuencode "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { - binary decode uuencode "``\$\"`P0``0(#" + binary decode uuencode ")``\$\"`P0``0(#" } -result "\0\1\2\3\4\0\1\2\3" test binary-75.6 {binary decode uuencode} -body { - string length [binary decode uuencode {`}] + string length [binary decode uuencode "`\n"] } -result 0 test binary-75.7 {binary decode uuencode} -body { - string length [binary decode uuencode {``}] + string length [binary decode uuencode "!`\n"] } -result 1 test binary-75.8 {binary decode uuencode} -body { - string length [binary decode uuencode {```}] + string length [binary decode uuencode "\"``\n"] } -result 2 test binary-75.9 {binary decode uuencode} -body { - string length [binary decode uuencode {````}] + string length [binary decode uuencode "#```\n"] } -result 3 test binary-75.10 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n>[string repeat 86)C 10]" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.11 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { binary decode uuencode -strict "|86)C" } -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} test binary-75.13 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]|[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]|[string repeat 86)C 10]" binary decode uuencode -strict $s -} -returnCodes error -match glob -result {invalid uuencode character "|" at position 40} +} -returnCodes error -match glob -result {invalid uuencode character "|" at position 41} test binary-75.14 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]" binary decode uuencode -strict $s } -returnCodes error -match glob -result {invalid uuencode character *} test binary-75.20 {binary decode uuencode} -body { - set r [binary decode uuencode 8] + set r [binary decode uuencode " 8"] list [string length $r] $r } -result {0 {}} test binary-75.21 {binary decode uuencode} -body { - set r [binary decode uuencode 86] + set r [binary decode uuencode "!86"] list [string length $r] $r } -result {1 a} test binary-75.22 {binary decode uuencode} -body { - set r [binary decode uuencode 86)] + set r [binary decode uuencode "\"86)"] list [string length $r] $r } -result {2 ab} test binary-75.23 {binary decode uuencode} -body { - set r [binary decode uuencode 86)C] + set r [binary decode uuencode "#86)C"] list [string length $r] $r } -result {3 abc} test binary-75.24 {binary decode uuencode} -body { - set s "04)\# " + set s "#04)\# " binary decode uuencode $s } -result ABC test binary-75.25 {binary decode uuencode} -body { - set s "04)\#z" + set s "#04)\#z" binary decode uuencode $s -} -returnCodes error -match glob -result {invalid uuencode character "z" at position 4} +} -returnCodes error -match glob -result {invalid uuencode character "z" at position 5} test binary-75.26 {binary decode uuencode} -body { string length [binary decode uuencode " "] } -result 0 -- cgit v0.12 From 826a355cc84e880287a692ccc1c3c48c915f5f4a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 16 Sep 2013 08:52:12 +0000 Subject: Be careful: separator needs to be bytes, not internal-encoded. --- generic/tclBinary.c | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 2053319..114984f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2586,13 +2586,15 @@ BinaryEncodeUu( unsigned char *data, *start, *cursor; int offset, count, rawLength, n, i, j, bits, index; int lineLength = 61; - const char *wrapchar = "\n"; - int wrapcharlen = 1; - enum {OPT_MAXLEN, OPT_WRAPCHAR }; + const unsigned char SingleNewline[] = { (unsigned char) '\n' }; + const unsigned char *wrapchar = SingleNewline; + int wrapcharlen = sizeof(SingleNewline); + enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc%2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); + Tcl_WrongNumArgs(interp, 1, objv, + "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { @@ -2613,7 +2615,7 @@ BinaryEncodeUu( } break; case OPT_WRAPCHAR: - wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen); break; } } @@ -2628,7 +2630,8 @@ BinaryEncodeUu( data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, - (lineLength + wrapcharlen) * ((count + (rawLength - 1)) / rawLength)); + (lineLength + wrapcharlen) * + ((count + (rawLength - 1)) / rawLength)); n = bits = 0; /* @@ -2657,7 +2660,7 @@ BinaryEncodeUu( *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; bits = 0; } - for (j=0; j Date: Mon, 16 Sep 2013 09:03:50 +0000 Subject: Refactor to remove unused flexibility. --- generic/tclBinary.c | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 114984f..58583f4 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -142,9 +142,9 @@ static const EnsembleImplMap binaryMap[] = { { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, + { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, - { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, + { "base64", BinaryEncode64, NULL, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap decodeMap[] = { @@ -2315,7 +2315,6 @@ BinaryEncodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; - const char *digits = clientData; int offset = 0, count = 0; if (objc != 2) { @@ -2327,8 +2326,8 @@ BinaryEncodeHex( data = Tcl_GetByteArrayFromObj(objv[1], &count); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { - *cursor++ = digits[((data[offset] >> 4) & 0x0f)]; - *cursor++ = digits[(data[offset] & 0x0f)]; + *cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)]; + *cursor++ = HexDigits[(data[offset] & 0x0f)]; } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2478,7 +2477,6 @@ BinaryEncode64( { Tcl_Obj *resultObj; unsigned char *data, *cursor, *limit; - const char *digits = clientData; int maxlen = 0; const char *wrapchar = "\n"; int wrapcharlen = 1; @@ -2537,17 +2535,17 @@ BinaryEncode64( for (i = 0; i < 3 && offset+i < count; ++i) { d[i] = data[offset + i]; } - OUTPUT(digits[d[0] >> 2]); - OUTPUT(digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); + OUTPUT(B64Digits[d[0] >> 2]); + OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); if (offset+1 < count) { - OUTPUT(digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); + OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } if (offset+2 < count) { - OUTPUT(digits[d[2] & 0x3f]); + OUTPUT(B64Digits[d[2] & 0x3f]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } } } -- cgit v0.12 From e1a2deb52347de47b6357eb9662c56ee98a4d81e Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 16 Sep 2013 23:18:54 +0000 Subject: [7b32d8d13b] Insert missing field initialization. --- generic/tclAssembly.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 100e9ef..946c729 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -2617,6 +2617,7 @@ AllocBB( bb->minStackDepth = 0; bb->maxStackDepth = 0; bb->finalStackDepth = 0; + bb->catchDepth = 0; bb->enclosingCatch = NULL; bb->foreignExceptionBase = -1; bb->foreignExceptionCount = 0; -- cgit v0.12 From 081808cdabb46c7e3f387d766ca6e58cc5c9af8f Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 17 Sep 2013 09:13:40 +0000 Subject: small improvements to the documentation --- doc/binary.n | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 0cdf465..cbbebd1 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -36,6 +36,13 @@ The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert binary data to or from string encodings such as base64 (used in MIME messages for example). .VE 8.6 +.PP +Note that other operations on binary data, such as taking a subsequence of it, +getting its length, or reinterpreting it as a string in some encoding, are +done by other Tcl commands (respectively \fBstring range\fR, +\fBstring length\fR and \fBencoding convertfrom\fR in the example cases). A +binary string in Tcl is merely one where all the characters it contains are in +the range \eu0000\-\eu00FF. .SH "BINARY ENCODE AND DECODE" .VS 8.6 .PP @@ -64,7 +71,7 @@ Indicates that the output should be split into lines of no more than . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character. +newline character, .QW \en . .PP During decoding, the following options are supported: @@ -95,7 +102,8 @@ between Unix systems and on USENET, but is less common these days, having been largely superseded by the \fBbase64\fR binary encoding. .RS .PP -During encoding, the following options are supported: +During encoding, the following options are supported (though changing them may +produce files that other implementations of decoders cannot process): .TP \fB\-maxlen \fIlength\fR . @@ -107,7 +115,7 @@ this must be in the range 3 to 85 due to limitations in the encoding. . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character. +newline character, .QW \en . .PP During decoding, the following options are supported: @@ -859,6 +867,7 @@ architectures, use their textual representation (as produced by .PP This is a procedure to write a Tcl string to a binary-encoded channel as UTF-8 data preceded by a length word: +.PP .CS proc \fIwriteString\fR {channel string} { set data [encoding convertto utf-8 $string] @@ -869,6 +878,7 @@ proc \fIwriteString\fR {channel string} { .PP This procedure reads a string from a channel that was written by the previously presented \fIwriteString\fR procedure: +.PP .CS proc \fIreadString\fR {channel} { if {![\fBbinary scan\fR [read $channel 4] I length]} { @@ -881,6 +891,7 @@ proc \fIreadString\fR {channel} { .PP This converts the contents of a file (named in the variable \fIfilename\fR) to base64 and prints them: +.PP .CS set f [open $filename rb] set data [read $f] @@ -888,9 +899,10 @@ close $f puts [\fBbinary encode\fR base64 \-maxlen 64 $data] .CE .SH "SEE ALSO" -format(n), scan(n), tcl_platform(n) +encoding(n), format(n), scan(n), string(n), tcl_platform(n) .SH KEYWORDS binary, format, scan '\" Local Variables: '\" mode: nroff +'\" fill-column: 78 '\" End: -- cgit v0.12 From 485b7e865a78e8d32056d25dc181e4b19e07be0c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 17 Sep 2013 09:20:58 +0000 Subject: ChangeLog entry --- ChangeLog | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/ChangeLog b/ChangeLog index 8e1a8b9..eaa5fc8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2013-09-17 Donal Fellows + + * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]: + Corrected implementation of the core of uuencode handling so that the + line length processing is correctly applied. + ***POTENTIAL INCOMPATIBILITY*** + Existing code that was using the old versions and working around the + limitations will now need to do far less. The -maxlen option now has + strict limits on the range of supported lengths; this is a limitation + of the format itself. + 2013-09-09 Donal Fellows * generic/tclOOMethod.c (CloneProcedureMethod): [Bug 3609693]: Strip -- cgit v0.12 From 868b8031fd65e9786ac1484f3fe1261c176ad5c0 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 18 Sep 2013 12:32:26 +0000 Subject: Bump TclOO version to 1.0.1 --- ChangeLog | 25 +++++++++++++++---------- generic/tclOO.h | 2 +- generic/tclOOBasic.c | 2 +- generic/tclOODefineCmds.c | 2 +- tests/oo.test | 4 ++-- tests/ooNext2.test | 2 +- unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 8 files changed, 23 insertions(+), 18 deletions(-) diff --git a/ChangeLog b/ChangeLog index eaa5fc8..3dc8c5e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,8 @@ -2013-09-17 Donal Fellows +2013-09-18 Donal Fellows + + Bump TclOO version to 1.0.1 for release. + +2013-09-17 Donal Fellows * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]: Corrected implementation of the core of uuencode handling so that the @@ -59,12 +63,13 @@ 2013-06-27 Jan Nijtmans - * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs initialized - * generic/tclMain.c: encodings. + * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs + * generic/tclMain.c: initialized encodings. 2013-06-18 Jan Nijtmans - * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread issue. + * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread + issue. 2013-06-17 Jan Nijtmans @@ -176,10 +181,10 @@ * generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit * generic/tclDecls.h: "long" type. Binary compatibility with win64 - requires that all stub entries use 32-bit long's, therefore the - need for various wrapper functions/macros. For Tcl 9 a better - solution is needed, but that cannot be done without introducing - binary incompatibility. + requires that all stub entries use 32-bit long's, therefore the need + for various wrapper functions/macros. For Tcl 9 a better solution is + needed, but that cannot be done without introducing binary + incompatibility. 2013-04-30 Andreas Kupries @@ -197,8 +202,8 @@ * generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj and Tcl_SetBooleanObj as macros using Tcl_NewIntObj, Tcl_DbNewLongObj - and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, - it only eliminates code duplication. + and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, it + only eliminates code duplication. * generic/tclInt.h: Eliminate use of NO_WIDE_TYPE everywhere: It's exactly the same as TCL_WIDE_INT_IS_LONG diff --git a/generic/tclOO.h b/generic/tclOO.h index cf253b1..d5ab8a0 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -39,7 +39,7 @@ extern const char *TclOOInitializeStubs( * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0" +#define TCLOO_VERSION "1.0.1" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index aba06a5..853e2ec 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,7 +4,7 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2005-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f0983cc..5a6c0ad 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2012 by Donal K. Fellows + * Copyright (c) 2006-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/oo.test b/tests/oo.test index 054bc46..37bbadb 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,12 +2,12 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2012 Donal K. Fellows +# Copyright (c) 2006-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. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index d77e8d1..a47aa91 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 721825b..08cc4c5 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0 +TCLOO_VERSION=1.0.1 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 721825b..08cc4c5 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0 +TCLOO_VERSION=1.0.1 -- cgit v0.12 From a57f75c197b1d3371c96802a894b9a85d84f2632 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 04:03:57 +0000 Subject: [3487626] Backport fix for knownBug test dict-23.2. --- generic/tclCompCmds.c | 7 +++++++ tests/dict.test | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index b6e9527..f96470d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -6149,6 +6149,7 @@ TclCompileEnsemble( Tcl_Parse synthetic; int len, numBytes, result, flags = 0, i; const char *word; + DefineLineInformation; if (parsePtr->numWords < 2) { return TCL_ERROR; @@ -6388,8 +6389,14 @@ TclCompileEnsemble( * Hand off compilation to the subcommand compiler. At last! */ + mapPtr->loc[eclIndex].line++; + mapPtr->loc[eclIndex].next++; + result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + mapPtr->loc[eclIndex].line--; + mapPtr->loc[eclIndex].next--; + /* * Clean up if necessary. */ diff --git a/tests/dict.test b/tests/dict.test index b92893e..a673957 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1212,7 +1212,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} { } }} [linenumber] } 5 -test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { +test dict-23.2 {dict compilation crash: Bug 3487626} { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are -- cgit v0.12 From 5260904a408218366fe2ef7a780eea2dc5922c9b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 04:11:01 +0000 Subject: [3487626] knownBug tests dict-23.2 and dist-24.21 already fixed on trunk. --- tests/dict.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/dict.test b/tests/dict.test index 02c9050..e898637 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1604,7 +1604,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} { } }} [linenumber]}} } 5 -test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { +test dict-23.2 {dict compilation crash: Bug 3487626} { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are @@ -1838,7 +1838,7 @@ test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} { } }} [linenumber]}} } 5 -test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug { +test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} { apply {{} {apply {n { set e {} set k {} -- cgit v0.12 From 6ad8909af3c178fac395992cd972c98270bf2e3c Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 04:20:53 +0000 Subject: Stop segfault due to OBOE in CompileWord() calls in [dict lappend] compiler. --- generic/tclCompCmds.c | 4 ++-- tests/dict.test | 6 ++++++ 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index f96470d..fa4762d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1313,8 +1313,8 @@ TclCompileDictLappendCmd( return TCL_ERROR; } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr); - CompileWord(envPtr, keyTokenPtr, interp, 3); - CompileWord(envPtr, valueTokenPtr, interp, 4); + CompileWord(envPtr, keyTokenPtr, interp, 2); + CompileWord(envPtr, valueTokenPtr, interp, 3); TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index a673957..6271779 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1243,6 +1243,12 @@ j } }} [linenumber] } 5 +test dict-23.3 {CompileWord OBOE} { + # segfault when buggy + apply {{} {tcl::dict::lappend foo bar \ + [format baz]}} +} {bar baz} + rename linenumber {} # cleanup -- cgit v0.12 From 9c7cec89a95143fb90c190c5c0f6d01424ea1431 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 12:20:13 +0000 Subject: Line numbers wrong in compiled foreach body. --- generic/tclCompCmds.c | 6 ++---- tests/foreach.test | 11 +++++++++++ 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fa4762d..2013568 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1628,7 +1628,7 @@ TclCompileForeachCmd( Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex; + int jumpBackDist, jumpBackOffset, infoIndex, range; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ @@ -1669,8 +1669,6 @@ TclCompileForeachCmd( return TCL_ERROR; } - bodyIndex = i-1; - /* * Allocate storage for the varcList and varvList arrays if necessary. */ @@ -1837,7 +1835,7 @@ TclCompileForeachCmd( * Inline compile the loop body. */ - SetLineInformation (bodyIndex); + SetLineInformation (numWords - 1); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); diff --git a/tests/foreach.test b/tests/foreach.test index 7df7481..ac7a279 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -254,6 +254,17 @@ test foreach-9.1 {compiled empty var list} { list [catch { foo } msg] $msg } {1 {foreach varlist is empty}} +test foreach-9.2 {line numbers} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + foreach x y {*}{ + } {return [incr n -[linenumber]]} + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + test foreach-10.1 {foreach: [Bug 1671087]} -setup { proc demo {} { set vals {1 2 3 4} -- cgit v0.12 From 3abcbb2542b51d5fd6df940805672cba4660c3ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 Sep 2013 12:37:13 +0000 Subject: consistant use of capitals. --- win/Makefile.in | 8 ++++---- win/makefile.bc | 28 ++++++++++++++-------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/win/Makefile.in b/win/Makefile.in index 235313f..6748f1b 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -586,23 +586,23 @@ install-binaries: binaries fi; \ done @if [ -f $(DDE_DLL_FILE) ]; then \ - echo installing $(DDE_DLL_FILE); \ + echo Installing $(DDE_DLL_FILE); \ $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ fi @if [ -f $(DDE_LIB_FILE) ]; then \ - echo installing $(DDE_LIB_FILE); \ + echo Installing $(DDE_LIB_FILE); \ $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ fi @if [ -f $(REG_DLL_FILE) ]; then \ - echo installing $(REG_DLL_FILE); \ + echo Installing $(REG_DLL_FILE); \ $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ fi @if [ -f $(REG_LIB_FILE) ]; then \ - echo installing $(REG_LIB_FILE); \ + echo Installing $(REG_LIB_FILE); \ $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ fi diff --git a/win/makefile.bc b/win/makefile.bc index 07b2333..3310b01 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -402,57 +402,57 @@ $(CAT32): $(WINDIR)\cat.c install-binaries: $(TCLSH) $(MKDIR) "$(BIN_INSTALL_DIR)" $(MKDIR) "$(LIB_INSTALL_DIR)" - @echo installing $(TCLDLLNAME) + @echo Installing $(TCLDLLNAME) @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)" @copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)" - @echo installing "$(TCLSH)" + @echo Installing "$(TCLSH)" @copy "$(TCLSH)" "$(BIN_INSTALL_DIR)" - @echo installing $(TCLPIPEDLLNAME) + @echo Installing $(TCLPIPEDLLNAME) @copy "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)" - @echo installing $(TCLSTUBLIBNAME) + @echo Installing $(TCLSTUBLIBNAME) @copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)" install-libraries: -@$(MKDIR) "$(LIB_INSTALL_DIR)" -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)" -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)" - @echo installing http1.0 + @echo Installing http1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" - @echo installing http2.7 + @echo Installing http2.7 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.7" -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.7" -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.7" - @echo installing opt0.4 + @echo Installing opt0.4 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" - @echo installing msgcat1.5 + @echo Installing msgcat1.5 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" - @echo installing tcltest2.3 + @echo Installing tcltest2.3 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.3" -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" - @echo installing platform1.0 + @echo Installing platform1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\platform.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\shell.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" - @echo installing $(TCLDDEDLLNAME) + @echo Installing $(TCLDDEDLLNAME) -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.3" -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.3" -@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.3" - @echo installing $(TCLREGDLLNAME) + @echo Installing $(TCLREGDLLNAME) -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.2" -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.2" -@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.2" - @echo installing encoding files + @echo Installing encoding files -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding" -@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding" - @echo installing library files + @echo Installing library files -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)" -- cgit v0.12 From 635d8c961aa06ec17403483a0ff3c0a3d524f3d1 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 13:06:06 +0000 Subject: Line numbers wrong in compiled [dict set]. --- generic/tclCompCmds.c | 8 +++----- tests/dict.test | 6 ++++++ 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 2013568..260bd28 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -683,11 +683,10 @@ TclCompileDictSetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; Proc *procPtr = envPtr->procPtr; DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - int dictVarIndex, nameChars; + int i, dictVarIndex, nameChars; const char *name; /* @@ -720,8 +719,7 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - numWords = parsePtr->numWords-1; - for (i=1 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -730,7 +728,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); + TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index 6271779..83f1ca7 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1248,6 +1248,12 @@ test dict-23.3 {CompileWord OBOE} { apply {{} {tcl::dict::lappend foo bar \ [format baz]}} } {bar baz} +test dict-23.4 {CompileWord OBOE} { + apply {n { + dict set foo {*}{ + } [return [incr n -[linenumber]]] val + }} [linenumber] +} 1 rename linenumber {} -- cgit v0.12 From 0467fcff78969cf483da62fc1c7b7cb9309cf16b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 13:39:40 +0000 Subject: [31661d2135] Plug memory leak. --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e402634..4d7bdd5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4327,7 +4327,7 @@ TEBCresume( if (listPtr->refCount == 1) { TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); - for (index=toIdx+1 ; indexelemCount = toIdx+1; -- cgit v0.12 From 071c731c5e45080a89c03c7ae74ec6acf4df59c2 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 14:06:46 +0000 Subject: Stop segfault due to OBOE in CompileWord() calls in [dict incr] compiler. --- generic/tclCompCmds.c | 2 +- tests/dict.test | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 260bd28..3445c09 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -806,7 +806,7 @@ TclCompileDictIncrCmd( * Emit the key and the code to actually do the increment. */ - CompileWord(envPtr, keyTokenPtr, interp, 3); + CompileWord(envPtr, keyTokenPtr, interp, 2); TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; diff --git a/tests/dict.test b/tests/dict.test index 83f1ca7..fec000d 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1254,6 +1254,11 @@ test dict-23.4 {CompileWord OBOE} { } [return [incr n -[linenumber]]] val }} [linenumber] } 1 +test dict-23.5 {CompileWord OBOE} { + # segfault when buggy + apply {{} {tcl::dict::incr foo \ + [format bar]}} +} {bar 1} rename linenumber {} -- cgit v0.12 From b9d177cec41c6ca4abcb019b38e7da7739ded8e7 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 14:21:21 +0000 Subject: [3606943]: Corrected description of method search order. --- ChangeLog | 5 +++++ doc/next.n | 11 +++++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3dc8c5e..b144110 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-09-19 Donal Fellows + + * doc/next.n (METHOD SEARCH ORDER): Bug [3606943]: Corrected + description of method search order. + 2013-09-18 Donal Fellows Bump TclOO version to 1.0.1 for release. diff --git a/doc/next.n b/doc/next.n index 0ad752a..fe7bddf 100644 --- a/doc/next.n +++ b/doc/next.n @@ -62,14 +62,14 @@ The method chain is cached for future use. When constructing the method chain, method implementations are searched for in the following order: .IP [1] -In the object. -.IP [2] In the classes mixed into the object, in class traversal order. The list of mixins is checked in natural order. -.IP [3] +.IP [2] In the classes mixed into the classes of the object, with sources of mixing in being searched in class traversal order. Within each class, the list of mixins is processed in natural order. +.IP [3] +In the object itself. .IP [4] In the object's class. .IP [5] @@ -77,7 +77,10 @@ In the superclasses of the class, following each superclass in a depth-first fashion in the natural order of the superclass list. .PP Any particular method implementation always comes as \fIlate\fR in the -resulting list of implementations as possible. +resulting list of implementations as possible; this means that if some class, +A, is both mixed into a class, B, and is also a superclass of B, the instances +of B will always treat A as a superclass from the perspective of inheritance. +This is true even when the multiple inheritance is processed indirectly. .SS FILTERS .PP When an object has a list of filter names set upon it, or is an instance of a -- cgit v0.12 From 08f3edbacbd40f9f76fb9e002b49516a5ffc3c62 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 14:48:02 +0000 Subject: Line numbers wrong in compiled [dict get]. --- generic/tclCompCmds.c | 7 +++---- tests/dict.test | 6 ++++++ 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3445c09..efb7ff2 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -822,7 +822,7 @@ TclCompileDictGetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -834,17 +834,16 @@ TclCompileDictGetCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Only compile this because we need INST_DICT_GET anyway. */ - for (i=0 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index fec000d..149599b 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1259,6 +1259,12 @@ test dict-23.5 {CompileWord OBOE} { apply {{} {tcl::dict::incr foo \ [format bar]}} } {bar 1} +test dict-23.6 {CompileWord OBOE} { + apply {n { + dict get {a b} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 rename linenumber {} -- cgit v0.12 From 58c74e141ff1c65580defe7237e86826b15afea2 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 14:55:05 +0000 Subject: Line numbers wrong in compiled [dict for]. --- generic/tclCompCmds.c | 2 +- tests/dict.test | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index efb7ff2..348910c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -934,7 +934,7 @@ TclCompileDictForCmd( * errors at this point. */ - CompileWord(envPtr, dictTokenPtr, interp, 3); + CompileWord(envPtr, dictTokenPtr, interp, 2); TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); emptyTargetOffset = CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); diff --git a/tests/dict.test b/tests/dict.test index 149599b..bd7b920 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1265,6 +1265,12 @@ test dict-23.6 {CompileWord OBOE} { } [return [incr n -[linenumber]]] }} [linenumber] } 1 +test dict-23.7 {CompileWord OBOE} { + apply {n { + dict for {a b} [return [incr n -[linenumber]]] {*}{ + } {} + }} [linenumber] +} 2 rename linenumber {} -- cgit v0.12 From 68feed9f4e09c3677ca335a790e197df2bdc5cf5 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 15:04:47 +0000 Subject: Line numbers wrong in compiled [dict update]. --- generic/tclCompCmds.c | 2 +- tests/dict.test | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 348910c..51a566e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1159,7 +1159,7 @@ TclCompileDictUpdateCmd( infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); for (i=0 ; i Date: Thu, 19 Sep 2013 15:44:21 +0000 Subject: Line numbers wrong in compiled [upvar]. --- generic/tclCompCmds.c | 16 ++++++++-------- tests/upvar.test | 11 +++++++++++ 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 51a566e..6189b29 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -5781,16 +5781,14 @@ TclCompileUpvarCmd( Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; int simpleVarName, isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { - Tcl_DecrRefCount(objPtr); return TCL_ERROR; } numWords = parsePtr->numWords; if (numWords < 3) { - Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -5798,6 +5796,7 @@ TclCompileUpvarCmd( * Push the frame index if it is known at compile time */ + objPtr = Tcl_NewObj(); tokenPtr = TokenAfter(parsePtr->tokenPtr); if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) { CallFrame *framePtr; @@ -5816,16 +5815,17 @@ TclCompileUpvarCmd( if(numWords%2) { return TCL_ERROR; } + /* TODO: Push the known value instead? */ CompileWord(envPtr, tokenPtr, interp, 1); otherTokenPtr = TokenAfter(tokenPtr); - i = 4; + i = 2; } else { if(!(numWords%2)) { return TCL_ERROR; } PushLiteral(envPtr, "1", 1); otherTokenPtr = tokenPtr; - i = 3; + i = 1; } } else { Tcl_DecrRefCount(objPtr); @@ -5838,12 +5838,12 @@ TclCompileUpvarCmd( * be called at runtime. */ - for(; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { + for(; i Date: Thu, 19 Sep 2013 16:04:48 +0000 Subject: Line numbers wrong in compiled [namespace upvar]. --- generic/tclCompCmds.c | 8 ++++---- tests/upvar.test | 21 +++++++++++++++++++++ 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6189b29..8e26a30 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -5920,7 +5920,7 @@ TclCompileNamespaceCmd( */ tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + CompileWord(envPtr, tokenPtr, interp, 2); /* * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a @@ -5929,13 +5929,13 @@ TclCompileNamespaceCmd( */ localTokenPtr = tokenPtr; - for(i=4; i<=numWords; i+=2) { + for(i=3; i Date: Thu, 19 Sep 2013 16:06:53 +0000 Subject: renumber tests for branch merge --- tests/upvar.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/upvar.test b/tests/upvar.test index df7f551..f90abef 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -553,7 +553,7 @@ test upvar-NS-1.9 {nsupvar links to correct variable} \ -returnCodes error \ -cleanup {namespace delete test_ns_1} -test upvar-NS-2.1 {CompileWord OBOE} -setup { +test upvar-NS-3.1 {CompileWord OBOE} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { @@ -563,7 +563,7 @@ test upvar-NS-2.1 {CompileWord OBOE} -setup { } -cleanup { rename linenumber {} } -result 1 -test upvar-NS-2.2 {CompileWord OBOE} -setup { +test upvar-NS-3.2 {CompileWord OBOE} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { -- cgit v0.12 From 44d124101c6297b356f7de3917c4d0666b8a0e31 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 16:33:36 +0000 Subject: Line numbers wrong in compiled [global] and [variable]. --- generic/tclCompCmds.c | 18 ++++++++++++------ tests/upvar.test | 10 ++++++++++ 2 files changed, 22 insertions(+), 6 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 8e26a30..809a6c6 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -6007,14 +6007,17 @@ TclCompileGlobalCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for(i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { + for(i=1; itokenPtr; - for(i=2; i<=numWords; i+=2) { + for(i=1; i Date: Thu, 19 Sep 2013 17:01:58 +0000 Subject: Line numbers wrong in compiled [dict exists]. --- generic/tclCompCmds.c | 7 +++---- tests/dict.test | 6 ++++++ 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9829b9c..64c110d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1002,7 +1002,7 @@ TclCompileDictExistsCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -1015,17 +1015,16 @@ TclCompileDictExistsCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Now we do the code generation. */ - for (i=0 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index 797ab46..6c254eb 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1899,6 +1899,12 @@ test dict-23.8 {CompileWord OBOE} { } [return [incr n -[linenumber]]] x {} }} [linenumber] } 1 +test dict-23.9 {CompileWord OBOE} { + apply {n { + dict exists {} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { -- cgit v0.12 From 91ec52b16e7cd903ca196560e5ddb1d5ca1c60a9 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 17:21:41 +0000 Subject: Line numbers wrong in compiled [dict with]. --- generic/tclCompCmds.c | 10 +++++----- tests/dict.test | 30 ++++++++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 64c110d..7e6b6da 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1875,7 +1875,7 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1902,7 +1902,7 @@ TclCompileDictWithCmd( tokenPtr = varTokenPtr; for (i=1 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1916,7 +1916,7 @@ TclCompileDictWithCmd( * Case: Direct dict in non-simple var with empty body. */ - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); PushStringLiteral(envPtr, ""); @@ -1951,13 +1951,13 @@ TclCompileDictWithCmd( */ if (dictVar == -1) { - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { for (i=2 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); diff --git a/tests/dict.test b/tests/dict.test index 6c254eb..a583de8 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1905,6 +1905,36 @@ test dict-23.9 {CompileWord OBOE} { } [return [incr n -[linenumber]]] }} [linenumber] } 1 +test dict-23.10 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.11 {CompileWord OBOE} { + apply {n { + dict with ::foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.12 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.13 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 +test dict-23.14 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { -- cgit v0.12 From 7b3702821be88e66474de1c1b1aa84c381276668 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 18:53:01 +0000 Subject: Line numbers wrong in compiled [unset]. --- generic/tclCompCmdsGR.c | 1 + generic/tclCompCmdsSZ.c | 14 +++++++------- tests/var.test | 13 +++++++++++++ 3 files changed, 21 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 4e4a3af..43ea3d3 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -587,6 +587,7 @@ TclCompileInfoCommandsCmd( * that the result needs to be list-ified. */ + /* TODO: Just push the known value */ CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d1eb9db..6c55e2e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2814,26 +2814,26 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, numWords, flags, i; + int isScalar, localIndex, flags, i; Tcl_Obj *leadingWord; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords-1; flags = 1; + i = 1; varTokenPtr = TokenAfter(parsePtr->tokenPtr); leadingWord = Tcl_NewObj(); - if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + if (parsePtr->numWords > 1 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { int len; const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; varTokenPtr = TokenAfter(varTokenPtr); - numWords--; + i++; } else if (len == 2 && !strncmp("--", bytes, 2)) { varTokenPtr = TokenAfter(varTokenPtr); - numWords--; + i++; } } else { /* @@ -2846,7 +2846,7 @@ TclCompileUnsetCmd( } TclDecrRefCount(leadingWord); - for (i=0 ; inumWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -2856,7 +2856,7 @@ TclCompileUnsetCmd( */ PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. diff --git a/tests/var.test b/tests/var.test index 5939100..6d4be26 100644 --- a/tests/var.test +++ b/tests/var.test @@ -862,6 +862,19 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup { }} array size x } -result 0 + +test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + set foo bar + unset foo {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + catch {namespace delete ns} catch {unset arr} -- cgit v0.12 From f19c90364c590451e85ba125933b3aa1fd9acd20 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 19:02:42 +0000 Subject: comment --- generic/tclCompCmdsSZ.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 6c55e2e..468c1c0 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1864,6 +1864,7 @@ TclCompileTailcallCmd( } /* make room for the nsObjPtr */ + /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); -- cgit v0.12 From cadf55303e72b696eedb9b29a469156b27fffa47 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 19:37:05 +0000 Subject: [3970f54c4e]: Corrected regression in argument order processing in [unset]. --- generic/tclCompCmdsSZ.c | 40 +++++++++++++++++++++++++--------------- tests/var.test | 3 +++ 2 files changed, 28 insertions(+), 15 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 468c1c0..b90bff8 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2815,19 +2815,37 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, flags, i; - Tcl_Obj *leadingWord; + int isScalar, localIndex, flags = 1, i; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ - flags = 1; - i = 1; + + /* + * Verify that all words are known at compile time so that we can handle + * them without needing to do a nasty push/rotate. [Bug 3970f54c4e] + */ + + for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { + varTokenPtr = TokenAfter(varTokenPtr); + if (!TclWordKnownAtCompileTime(varTokenPtr, NULL)) { + return TCL_ERROR; + } + } + + /* + * Check for options; if they're present we'll know for sure because we + * know we're all constant arguments. + */ + varTokenPtr = TokenAfter(parsePtr->tokenPtr); - leadingWord = Tcl_NewObj(); - if (parsePtr->numWords > 1 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + i = 1; + if (parsePtr->numWords > 1) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + const char *bytes; int len; - const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); + (void) TclWordKnownAtCompileTime(varTokenPtr, leadingWord); + bytes = Tcl_GetStringFromObj(leadingWord, &len); if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; varTokenPtr = TokenAfter(varTokenPtr); @@ -2836,16 +2854,8 @@ TclCompileUnsetCmd( varTokenPtr = TokenAfter(varTokenPtr); i++; } - } else { - /* - * Cannot guarantee that the first word is not '-nocomplain' at - * evaluation with reasonable effort, so spill to interpreted version. - */ - TclDecrRefCount(leadingWord); - return TCL_ERROR; } - TclDecrRefCount(leadingWord); for ( ; inumWords ; i++) { /* diff --git a/tests/var.test b/tests/var.test index 6d4be26..208b361 100644 --- a/tests/var.test +++ b/tests/var.test @@ -748,6 +748,9 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test A useSomeUnlikelyNameHere namespace eval test unset useSomeUnlikelyNameHere } {} +test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} { + apply {{} {unset foo [return ok]}} +} ok test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" -- cgit v0.12 From 2139c0e39e6fb83eb76edc0088de73b9caa7cdb3 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 22:37:06 +0000 Subject: [3970f54c4e]: Improved fix that is more tolerant of a single variable varname. --- generic/tclCompCmdsSZ.c | 82 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 57 insertions(+), 25 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index b90bff8..44cb66e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2815,49 +2815,81 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, flags = 1, i; + int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ /* - * Verify that all words are known at compile time so that we can handle - * them without needing to do a nasty push/rotate. [Bug 3970f54c4e] + * Verify that all words - except the first non-option one - are known at + * compile time so that we can handle them without needing to do a nasty + * push/rotate. [Bug 3970f54c4e] */ for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + varTokenPtr = TokenAfter(varTokenPtr); - if (!TclWordKnownAtCompileTime(varTokenPtr, NULL)) { + if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + TclDecrRefCount(leadingWord); + + /* + * We can tolerate non-trivial substitutions in the first variable + * to be unset. If a '--' or '-nocomplain' was present, anything + * goes in that one place! (All subsequent variable names must be + * constants since we don't want to have to push them all first.) + */ + + if (varCount == 0) { + if (haveFlags) { + continue; + } + + /* + * In fact, we're OK as long as we're the first argument *and* + * we provably don't start with a '-'. If that is true, then + * even if everything else is varying, we still can't be a + * flag. Otherwise we'll spill to runtime to place a limit on + * the trickiness. + */ + + if (varTokenPtr->type == TCL_TOKEN_WORD + && varTokenPtr[1].type == TCL_TOKEN_TEXT + && varTokenPtr[1].size > 0 + && varTokenPtr[1].start[0] != '-') { + continue; + } + } return TCL_ERROR; } + if (i == 1) { + const char *bytes; + int len; + + bytes = Tcl_GetStringFromObj(leadingWord, &len); + if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { + flags = 0; + haveFlags = 1; + } else if (len == 2 && !strncmp("--", bytes, 2)) { + haveFlags = 1; + } else { + varCount++; + } + } else { + varCount++; + } + TclDecrRefCount(leadingWord); } /* - * Check for options; if they're present we'll know for sure because we - * know we're all constant arguments. + * Issue instructions to unset each of the named variables. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - i = 1; - if (parsePtr->numWords > 1) { - Tcl_Obj *leadingWord = Tcl_NewObj(); - const char *bytes; - int len; - - (void) TclWordKnownAtCompileTime(varTokenPtr, leadingWord); - bytes = Tcl_GetStringFromObj(leadingWord, &len); - if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { - flags = 0; - varTokenPtr = TokenAfter(varTokenPtr); - i++; - } else if (len == 2 && !strncmp("--", bytes, 2)) { - varTokenPtr = TokenAfter(varTokenPtr); - i++; - } - TclDecrRefCount(leadingWord); + if (haveFlags) { + varTokenPtr = TokenAfter(varTokenPtr); } - - for ( ; inumWords ; i++) { + for (i=1+haveFlags ; inumWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a -- cgit v0.12 From c4175e0434a242a24610b0c3a70214885b897006 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 20 Sep 2013 09:11:51 +0000 Subject: Make sure that panic's during finalization are handled by the custom panicproc not by the default panicproc, because stderr might not be available. When the default panicproc is in use, this doesn't make any difference. --- generic/tclEvent.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 686b80d..941d566 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1171,8 +1171,6 @@ Tcl_Finalize(void) TclFinalizeEncodingSubsystem(); - Tcl_SetPanicProc(NULL); - /* * Repeat finalization of the thread local storage once more. Although * this step is already done by the Tcl_FinalizeThread call above, series -- cgit v0.12 From 5d9b0d315794199313c41559a91710addd1d4630 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 23 Sep 2013 11:12:12 +0000 Subject: workaround for mingw bug [http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724] --- win/configure | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- win/tcl.m4 | 21 +++++++++++++++--- 2 files changed, 84 insertions(+), 6 deletions(-) diff --git a/win/configure b/win/configure index a0be0c4..0a293ca 100755 --- a/win/configure +++ b/win/configure @@ -3437,6 +3437,8 @@ echo "${ECHO_T}yes" >&6 # set various compiler flags depending on whether we are using gcc or cl if test "${GCC}" = "yes" ; then + extra_cflags="-pipe" + extra_ldflags="-pipe" echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5 echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6 if test "${ac_cv_win32+set}" = set; then @@ -3500,6 +3502,70 @@ echo "${ECHO_T}$ac_cv_win32" >&6 echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;} { (exit 1); exit 1; }; } fi + + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" + echo "$as_me:$LINENO: checking for working -municode linker flag" >&5 +echo $ECHO_N "checking for working -municode linker flag... $ECHO_C" >&6 +if test "${ac_cv_municode+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + + #include + int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 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_exeext' + { (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 + ac_cv_municode=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_municode=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +fi +echo "$as_me:$LINENO: result: $ac_cv_municode" >&5 +echo "${ECHO_T}$ac_cv_municode" >&6 + CFLAGS=$hold_cflags + if test "$ac_cv_municode" = "no" ; then + extra_ldflags="$extra_ldflags -static-libgcc" + fi fi echo "$as_me:$LINENO: checking compiler flags" >&5 @@ -3521,9 +3587,6 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 MAKE_EXE="\${CC} -o \$@" LIBPREFIX="lib" - extra_cflags="-pipe" - extra_ldflags="-pipe" - if test "${SHARED_BUILD}" = "0" ; then # static echo "$as_me:$LINENO: result: using static flags" >&5 diff --git a/win/tcl.m4 b/win/tcl.m4 index 5696366..589a8c0 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -632,6 +632,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # set various compiler flags depending on whether we are using gcc or cl if test "${GCC}" = "yes" ; then + extra_cflags="-pipe" + extra_ldflags="-pipe" AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ @@ -645,6 +647,22 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "$ac_cv_win32" != "yes"; then AC_MSG_ERROR([${CC} cannot produce win32 executables.]) fi + + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" + AC_CACHE_CHECK(for working -municode linker flag, + ac_cv_municode, + AC_TRY_LINK([ + #include + int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} + ], + [], + ac_cv_municode=yes, + ac_cv_municode=no) + ) + CFLAGS=$hold_cflags + if test "$ac_cv_municode" = "no" ; then + extra_ldflags="$extra_ldflags -static-libgcc" + fi fi AC_MSG_CHECKING([compiler flags]) @@ -665,9 +683,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ MAKE_EXE="\${CC} -o \[$]@" LIBPREFIX="lib" - extra_cflags="-pipe" - extra_ldflags="-pipe" - if test "${SHARED_BUILD}" = "0" ; then # static AC_MSG_RESULT([using static flags]) -- cgit v0.12 From b54c2a5958b12875dc5a32cc1f09da20e23b087d Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 23 Sep 2013 12:18:45 +0000 Subject: revert mistaken commit of experiment --- generic/tclIOUtil.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6332453..6259216 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1944,7 +1944,7 @@ TclNREvalFile( iPtr->evalFlags |= TCL_EVAL_FILE; TclNRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr, NULL); - return TclNREvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, INT_MIN); + return TclNREvalObjEx(interp, objPtr, 0, NULL, INT_MIN); } static int -- cgit v0.12 From f43e26d84c0342402389b06a5fa4e419a927e541 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 25 Sep 2013 16:39:26 +0000 Subject: Test demonstrating need for "adjust" manipulation in TclSubstTokens. --- tests/source.test | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/source.test b/tests/source.test index 641838c..dc3c2d8 100644 --- a/tests/source.test +++ b/tests/source.test @@ -187,6 +187,16 @@ test source-3.5 {return with special code etc.} -setup { invoked from within "source $sourcefile"} {a b c}} +test source-4.1 {continuation line parsing} -setup { + set sourcefile [makeFile [string map {CL \\\n} { + format %s "[dict get [info frame 0] type]:CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]" + }] source.file] +} -body { + source $sourcefile +} -cleanup { + removeFile source.file +} -result {source: 3 4 5} + test source-6.1 {source is binary ok} -setup { # Note [makeFile] writes in the system encoding. # [source] defaults to reading in the system encoding. -- cgit v0.12 From 2d6233b88ed95056ca253dc72bf44017a82bb239 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 25 Sep 2013 22:54:29 +0000 Subject: [d614d63989] Ensure that there are no trailing colons as that causes chaos when a deleteProc is specified. --- generic/tclNamesp.c | 83 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 59 insertions(+), 24 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index d2decb9..4b72e03 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -737,6 +737,10 @@ Tcl_CreateNamespace( Tcl_DString *namePtr, *buffPtr; int newEntry, nameLen; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + const char *nameStr; + Tcl_DString tmpBuffer; + + Tcl_DStringInit(&tmpBuffer); /* * If there is no active namespace, the interpreter is being initialized. @@ -750,39 +754,68 @@ Tcl_CreateNamespace( parentPtr = NULL; simpleName = ""; - } else if (*name == '\0') { + goto doCreate; + } + + /* + * Ensure that there are no trailing colons as that causes chaos when a + * deleteProc is specified. [Bug d614d63989] + */ + + if (deleteProc != NULL) { + nameStr = name + strlen(name) - 2; + if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') { + Tcl_DStringAppend(&tmpBuffer, name, -1); + while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0 + && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') { + Tcl_DStringSetLength(&tmpBuffer, nameLen-1); + } + name = Tcl_DStringValue(&tmpBuffer); + } + } + + /* + * If we've ended up with an empty string now, we're attempting to create + * the global namespace despite the global namespace existing. That's + * naughty! + */ + + if (*name == '\0') { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't create namespace \"\": " "only global namespace can have empty name", NULL); + Tcl_DStringFree(&tmpBuffer); return NULL; - } else { - /* - * Find the parent for the new namespace. - */ + } - TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN, - &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); + /* + * Find the parent for the new namespace. + */ - /* - * If the unqualified name at the end is empty, there were trailing - * "::"s after the namespace's name which we ignore. The new namespace - * was already (recursively) created and is pointed to by parentPtr. - */ + TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN, + &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); - if (*simpleName == '\0') { - return (Tcl_Namespace *) parentPtr; - } + /* + * If the unqualified name at the end is empty, there were trailing "::"s + * after the namespace's name which we ignore. The new namespace was + * already (recursively) created and is pointed to by parentPtr. + */ - /* - * Check for a bad namespace name and make sure that the name does not - * already exist in the parent namespace. - */ + if (*simpleName == '\0') { + Tcl_DStringFree(&tmpBuffer); + return (Tcl_Namespace *) parentPtr; + } - if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { - Tcl_AppendResult(interp, "can't create namespace \"", name, - "\": already exists", NULL); - return NULL; - } + /* + * Check for a bad namespace name and make sure that the name does not + * already exist in the parent namespace. + */ + + if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { + Tcl_AppendResult(interp, "can't create namespace \"", name, + "\": already exists", NULL); + Tcl_DStringFree(&tmpBuffer); + return NULL; } /* @@ -790,6 +823,7 @@ Tcl_CreateNamespace( * of namespaces created. */ + doCreate: nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); nsPtr->name = ckalloc((unsigned) (strlen(simpleName)+1)); strcpy(nsPtr->name, simpleName); @@ -879,6 +913,7 @@ Tcl_CreateNamespace( Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); + Tcl_DStringFree(&tmpBuffer); /* * Return a pointer to the new namespace. -- cgit v0.12 From 38f8605a8d202951bbf792a4813b9b48a20910fb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 Sep 2013 14:27:37 +0000 Subject: Tcl_SetResult -> Tcl_SetObjResult --- generic/tclBinary.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 58583f4..4e977f2 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2500,7 +2500,8 @@ BinaryEncode64( return TCL_ERROR; } if (maxlen < 0) { - Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; @@ -2606,7 +2607,8 @@ BinaryEncodeUu( return TCL_ERROR; } if (lineLength < 3 || lineLength > 85) { - Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; -- cgit v0.12 From 790f8f7114d0cc7b44cbaddc66e36c877c9c55b6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Sep 2013 09:18:36 +0000 Subject: Workaround for [http://sourceforge.net/p/mingw/bugs/2065/|MinGW bug #2065]. Both MinGW and MinGW-w64 (32-bit) are affected. Even though Win64 is not affected, adding -static-libgcc doesn't harm there, and we don't want to distrubute additional dll's with MinGW-compiled Tcl anyway. --- win/configure | 3 +-- win/tcl.m4 | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/win/configure b/win/configure index be9c98a..d09b588 100755 --- a/win/configure +++ b/win/configure @@ -3450,7 +3450,7 @@ echo "${ECHO_T}yes" >&6 if test "${GCC}" = "yes" ; then extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_ldflags="-pipe -static-libgcc" echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5 echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6 if test "${ac_cv_win32+set}" = set; then @@ -3579,7 +3579,6 @@ echo "${ECHO_T}$ac_cv_municode" >&6 extra_ldflags="$extra_ldflags -municode" else extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" - extra_ldflags="$extra_ldflags -static-libgcc" fi fi diff --git a/win/tcl.m4 b/win/tcl.m4 index 335494b..7ea7fad 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -634,7 +634,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "${GCC}" = "yes" ; then extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_ldflags="-pipe -static-libgcc" AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ @@ -665,7 +665,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ extra_ldflags="$extra_ldflags -municode" else extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" - extra_ldflags="$extra_ldflags -static-libgcc" fi fi -- cgit v0.12 From 3b36134fe4997423da879edc4f400e411a702901 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Sep 2013 09:35:05 +0000 Subject: Cherrypick [87d1313df3] from trunk: Workaround for [http://sourceforge.net/p/mingw/bugs/2065/|MinGW bug #2065]. Both MinGW and MinGW-w64 (32-bit) are affected. Even though Win64 is not affected, adding -static-libgcc doesn't harm there, and we don't want to distrubute additional dll's with MinGW-compiled Tcl anyway. --- win/configure | 66 +---------------------------------------------------------- win/tcl.m4 | 18 +--------------- 2 files changed, 2 insertions(+), 82 deletions(-) diff --git a/win/configure b/win/configure index 0a293ca..8e1d0e8 100755 --- a/win/configure +++ b/win/configure @@ -3438,7 +3438,7 @@ echo "${ECHO_T}yes" >&6 if test "${GCC}" = "yes" ; then extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_ldflags="-pipe -static-libgcc" echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5 echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6 if test "${ac_cv_win32+set}" = set; then @@ -3502,70 +3502,6 @@ echo "${ECHO_T}$ac_cv_win32" >&6 echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;} { (exit 1); exit 1; }; } fi - - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" - echo "$as_me:$LINENO: checking for working -municode linker flag" >&5 -echo $ECHO_N "checking for working -municode linker flag... $ECHO_C" >&6 -if test "${ac_cv_municode+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - - #include - int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} - -int -main () -{ - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 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_exeext' - { (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 - ac_cv_municode=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_municode=no -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - -fi -echo "$as_me:$LINENO: result: $ac_cv_municode" >&5 -echo "${ECHO_T}$ac_cv_municode" >&6 - CFLAGS=$hold_cflags - if test "$ac_cv_municode" = "no" ; then - extra_ldflags="$extra_ldflags -static-libgcc" - fi fi echo "$as_me:$LINENO: checking compiler flags" >&5 diff --git a/win/tcl.m4 b/win/tcl.m4 index 589a8c0..7de3013 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -633,7 +633,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "${GCC}" = "yes" ; then extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_ldflags="-pipe -static-libgcc" AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ @@ -647,22 +647,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "$ac_cv_win32" != "yes"; then AC_MSG_ERROR([${CC} cannot produce win32 executables.]) fi - - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" - AC_CACHE_CHECK(for working -municode linker flag, - ac_cv_municode, - AC_TRY_LINK([ - #include - int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} - ], - [], - ac_cv_municode=yes, - ac_cv_municode=no) - ) - CFLAGS=$hold_cflags - if test "$ac_cv_municode" = "no" ; then - extra_ldflags="$extra_ldflags -static-libgcc" - fi fi AC_MSG_CHECKING([compiler flags]) -- cgit v0.12 From a5a2f896bb91053061b5a83f09cb0778c3b53e3b Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 27 Sep 2013 10:29:43 +0000 Subject: =?UTF-8?q?[219226]:=20Rewrote=20how=20::env=20is=20synchronized?= =?UTF-8?q?=20to=20the=20environment=20so=20it=20no=20longer=20smashes=20t?= =?UTF-8?q?he=20array=20or=20its=20elements=20flat,=20This=20affects=20tra?= =?UTF-8?q?ces=20on=20env,=20links=20to=20env,=20and=20iterations=20over?= =?UTF-8?q?=20env:=20it=20makes=20them=20work=20as=20na=C3=AFvely=20expect?= =?UTF-8?q?ed.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclEnv.c | 81 +++++++++++++++++++++++++++++++++++++++++++++----------- generic/tclInt.h | 2 ++ generic/tclVar.c | 47 ++++++++++++++++++++++++++++++++ tests/env.test | 23 ++++++++++++++++ 4 files changed, 137 insertions(+), 16 deletions(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index b5ae6ea..6a21947 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -76,36 +76,56 @@ TclSetupEnv( Tcl_Interp *interp) /* Interpreter whose "env" array is to be * managed. */ { + Var *varPtr, *arrayPtr; + Tcl_Obj *varNamePtr; Tcl_DString envString; - char *p1, *p2; - int i; + Tcl_HashTable namesHash; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; /* * Synchronize the values in the environ array with the contents of the * Tcl "env" variable. To do this: - * 1) Remove the trace that fires when the "env" var is unset. - * 2) Unset the "env" variable. - * 3) If there are no environ variables, create an empty "env" array. - * Otherwise populate the array with current values. - * 4) Add a trace that synchronizes the "env" array. + * 1) Remove the trace that fires when the "env" var is updated. + * 2) Find the existing contents of the "env", storing in a hash table. + * 3) Create/update elements for each environ variable, removing + * elements from the hash table as we go. + * 4) Remove the elements for each remaining entry in the hash table, + * which must have existed before yet have no analog in the environ + * variable. + * 5) Add a trace that synchronizes the "env" array. */ Tcl_UntraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); - Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY); + /* + * Find out what elements are currently in the global env array. + */ - if (environ[0] == NULL) { - Tcl_Obj *varNamePtr; + TclNewLiteralStringObj(varNamePtr, "env"); + Tcl_IncrRefCount(varNamePtr); + Tcl_InitObjHashTable(&namesHash); + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + TclFindArrayPtrElements(varPtr, &namesHash); + + /* + * Go through the environment array and transfer its values into Tcl. At + * the same time, remove those elements we add/update from the hash table + * of existing elements, so that after this part processes, that table + * will hold just the parts to remove. + */ + + if (environ[0] != NULL) { + int i; - TclNewLiteralStringObj(varNamePtr, "env"); - Tcl_IncrRefCount(varNamePtr); - TclArraySet(interp, varNamePtr, NULL); - Tcl_DecrRefCount(varNamePtr); - } else { Tcl_MutexLock(&envMutex); for (i = 0; environ[i] != NULL; i++) { + Tcl_Obj *obj1, *obj2; + char *p1, *p2; + p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); p2 = strchr(p1, '='); if (p2 == NULL) { @@ -119,12 +139,41 @@ TclSetupEnv( } p2++; p2[-1] = '\0'; - Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); + obj1 = Tcl_NewStringObj(p1, -1); + obj2 = Tcl_NewStringObj(p2, -1); Tcl_DStringFree(&envString); + + Tcl_IncrRefCount(obj1); + Tcl_IncrRefCount(obj2); + Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY); + hPtr = Tcl_FindHashEntry(&namesHash, obj1); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DecrRefCount(obj1); + Tcl_DecrRefCount(obj2); } Tcl_MutexUnlock(&envMutex); } + /* + * Delete those elements that existed in the array but which had no + * counterparts in the environment array. + */ + + for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL; + hPtr=Tcl_NextHashEntry(&search)) { + Tcl_Obj *elemName = Tcl_GetHashValue(hPtr); + + TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY); + } + Tcl_DeleteHashTable(&namesHash); + Tcl_DecrRefCount(varNamePtr); + + /* + * Re-establish the trace. + */ + Tcl_TraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); diff --git a/generic/tclInt.h b/generic/tclInt.h index 380284f..feea6dd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3857,6 +3857,8 @@ MODULE_SCOPE int TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *part2Ptr, const int flags, int index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); +MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, + Tcl_HashTable *tablePtr); /* * The new extended interface to the variable traces. diff --git a/generic/tclVar.c b/generic/tclVar.c index af1a563..4694cd8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3850,6 +3850,53 @@ ArrayNamesCmd( /* *---------------------------------------------------------------------- * + * TclFindArrayPtrElements -- + * + * Fill out a hash table (which *must* use Tcl_Obj* keys) with an entry + * for each existing element of the given array. The provided hash table + * is assumed to be initially empty. + * + * Result: + * none + * + * Side effects: + * The keys of the array gain an extra reference. The supplied hash table + * has elements added to it. + * + *---------------------------------------------------------------------- + */ + +void +TclFindArrayPtrElements( + Var *arrayPtr, + Tcl_HashTable *tablePtr) +{ + Var *varPtr; + Tcl_HashSearch search; + + if ((arrayPtr == NULL) || !TclIsVarArray(arrayPtr) + || TclIsVarUndefined(arrayPtr)) { + return; + } + + for (varPtr=VarHashFirstVar(arrayPtr->value.tablePtr, &search); + varPtr!=NULL ; varPtr=VarHashNextVar(&search)) { + Tcl_HashEntry *hPtr; + Tcl_Obj *nameObj; + int dummy; + + if (TclIsVarUndefined(varPtr)) { + continue; + } + nameObj = VarHashGetKey(varPtr); + hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy); + Tcl_SetHashValue(hPtr, nameObj); + } +} + +/* + *---------------------------------------------------------------------- + * * ArraySetCmd -- * * This object-based function is invoked to process the "array set" Tcl diff --git a/tests/env.test b/tests/env.test index fa76433..8115652 100644 --- a/tests/env.test +++ b/tests/env.test @@ -291,6 +291,29 @@ test env-6.1 {corner cases - add lots of env variables} {} { expr {[array size env] - $size} } 100 +test env-7.1 {[219226]: whole env array should not be unset by read} { + set n [array size env] + set s [array startsearch env] + while {[array anymore env $s]} { + array nextelement env $s + incr n -1 + } + array donesearch env $s + return $n +} 0 +test env-7.2 {[219226]: links to env elements should not be removed by read} { + apply {{} { + set ::env(test7_2) ok + upvar env(test7_2) elem + set ::env(PATH) + try { + return $elem + } finally { + unset ::env(test7_2) + } + }} +} ok + # Restore the environment variables at the end of the test. foreach name [array names env] { -- cgit v0.12 From ad4355066f0d4cdafaa288933a1517e6c79817ad Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 27 Sep 2013 17:33:17 +0000 Subject: Fix test source-4.1 --- generic/tclCompile.c | 6 +++++- tests/source.test | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f5c8d41..d15ef3a 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2229,7 +2229,7 @@ TclCompileTokens( Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; - int i, numObjsToConcat, length; + int i, numObjsToConcat, length, adjust; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; @@ -2266,6 +2266,7 @@ TclCompileTokens( clPosition = ckalloc(maxNumCL * sizeof(int)); } + adjust = 0; Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { @@ -2309,6 +2310,7 @@ TclCompileTokens( clPosition[numCL] = clPos; numCL ++; } + adjust++; } break; @@ -2331,8 +2333,10 @@ TclCompileTokens( numCL = 0; } + envPtr->line += adjust; TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); + envPtr->line -= adjust; numObjsToConcat++; break; diff --git a/tests/source.test b/tests/source.test index 6ee2198..0235bd1 100644 --- a/tests/source.test +++ b/tests/source.test @@ -187,7 +187,7 @@ test source-3.5 {return with special code etc.} -setup { invoked from within "source $sourcefile"} {a b c}} -test source-4.1 {continuation line parsing} -constraints knownBug -setup { +test source-4.1 {continuation line parsing} -setup { set sourcefile [makeFile [string map {CL \\\n} { format %s "[dict get [info frame 0] type]:CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]" }] source.file] -- cgit v0.12 From 789e4ada24cc5f08a6d5300e354a752cdb066eec Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Sep 2013 21:10:22 +0000 Subject: [dfc08326e3]: Corrected symbol export for TclOO to match Tcl so things work as expected in a static build. --- generic/tclOO.decls | 21 +++++++++++++++--- generic/tclOODecls.h | 58 ++++++++++++++++++++++++------------------------- generic/tclOOIntDecls.h | 32 +++++++++++++-------------- 3 files changed, 63 insertions(+), 48 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 31d1113..19d3f03 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,12 +1,25 @@ +# tclOO.decls -- +# +# This file contains the declarations for all supported public functions +# that are exported by the TclOO package that is embedded within the Tcl +# library via the stubs table. This file is used to generate the +# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c +# files. +# +# Copyright (c) 2008-2013 by Donal K. Fellows. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + library tclOO +scspec EXTERN ###################################################################### -# public API +# Public API, exposed for general users of TclOO. # interface tclOO hooks tclOOInt -scspec TCLOOAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, @@ -116,7 +129,9 @@ declare 28 { } ###################################################################### -# private API, exposed to support advanced OO systems that plug in on top +# Private API, exposed to support advanced OO systems that plug in on top of +# TclOO; not intended for general use and does not have any commitment to +# long-term support. # interface tclOOInt diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 58871c6..9cb704e 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -12,92 +12,92 @@ */ /* 0 */ -TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); +EXTERN int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, +EXTERN int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); +EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); +EXTERN int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -TCLOOAPI int Tcl_ObjectContextIsFiltering( +EXTERN int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -TCLOOAPI int Tcl_ObjectContextSkippedArgs( +EXTERN int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, +EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, +EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index acafb18..834d8cb 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -12,46 +12,46 @@ */ /* 0 */ -TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); +EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -60,7 +60,7 @@ TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -69,22 +69,22 @@ TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, +EXTERN int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, +EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, +EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, +EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, +EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); -- cgit v0.12 From 6a1cc41ccac84140abbe6011995eefbf2e8a4435 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Sep 2013 22:52:11 +0000 Subject: typo; spotted by stu --- doc/Class.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Class.3 b/doc/Class.3 index 28cea9b..febe703 100644 --- a/doc/Class.3 +++ b/doc/Class.3 @@ -111,7 +111,7 @@ function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR is a shared reference. .PP Instances of classes are created using \fBTcl_NewObjectInstance\fR, which -takes creates an object from any class (and which is internally called by both +creates an object from any class (and which is internally called by both the \fBcreate\fR and \fBnew\fR methods of the \fBoo::class\fR class). It takes parameters that optionally give the name of the object and namespace to create, and which describe the arguments to pass to the class's constructor -- cgit v0.12 From 11fdcc3fedcd680e93a93d28bf862d388ada3f9d 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 5d83a3919d8912254cb477b87abab826cf78bc53 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Sep 2013 09:03:20 +0000 Subject: Fix [f51efe99a7] by reverting [371bcd0714] --- generic/tclOO.decls | 21 +++--------------- generic/tclOODecls.h | 58 ++++++++++++++++++++++++------------------------- generic/tclOOIntDecls.h | 32 +++++++++++++-------------- 3 files changed, 48 insertions(+), 63 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 19d3f03..31d1113 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,25 +1,12 @@ -# tclOO.decls -- -# -# This file contains the declarations for all supported public functions -# that are exported by the TclOO package that is embedded within the Tcl -# library via the stubs table. This file is used to generate the -# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c -# files. -# -# Copyright (c) 2008-2013 by Donal K. Fellows. -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - library tclOO -scspec EXTERN ###################################################################### -# Public API, exposed for general users of TclOO. +# public API # interface tclOO hooks tclOOInt +scspec TCLOOAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, @@ -129,9 +116,7 @@ declare 28 { } ###################################################################### -# Private API, exposed to support advanced OO systems that plug in on top of -# TclOO; not intended for general use and does not have any commitment to -# long-term support. +# private API, exposed to support advanced OO systems that plug in on top # interface tclOOInt diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 9cb704e..58871c6 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -12,92 +12,92 @@ */ /* 0 */ -EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -EXTERN int Tcl_MethodIsPublic(Tcl_Method method); +TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -EXTERN int Tcl_MethodIsType(Tcl_Method method, +TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); +TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -EXTERN int Tcl_ObjectDeleted(Tcl_Object object); +TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -EXTERN int Tcl_ObjectContextIsFiltering( +TCLOOAPI int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -EXTERN int Tcl_ObjectContextSkippedArgs( +TCLOOAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, +TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, +TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, +TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, +TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 834d8cb..acafb18 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -12,46 +12,46 @@ */ /* 0 */ -EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); +TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -60,7 +60,7 @@ EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -69,22 +69,22 @@ EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -EXTERN int TclOOInvokeObject(Tcl_Interp *interp, +TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, +TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, +TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, +TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, +TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); -- cgit v0.12 From 09b2762b8a6317ae6ef595df2c9dd239fd4749b3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Sep 2013 09:38:49 +0000 Subject: Restore copyright assignments and some improved comments in tclOO.decls: previous commit was a blind revert of [371bcd0714], but those changes should not have been reverted. --- generic/tclOO.decls | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 31d1113..f22390e 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,12 +1,25 @@ +# tclOO.decls -- +# +# This file contains the declarations for all supported public functions +# that are exported by the TclOO package that is embedded within the Tcl +# library via the stubs table. This file is used to generate the +# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c +# files. +# +# Copyright (c) 2008-2013 by Donal K. Fellows. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + library tclOO +scspec TCLOOAPI ###################################################################### -# public API +# Public API, exposed for general users of TclOO. # interface tclOO hooks tclOOInt -scspec TCLOOAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, @@ -116,7 +129,9 @@ declare 28 { } ###################################################################### -# private API, exposed to support advanced OO systems that plug in on top +# Private API, exposed to support advanced OO systems that plug in on top of +# TclOO; not intended for general use and does not have any commitment to +# long-term support. # interface tclOOInt -- cgit v0.12 From 228c6fd96ff315b9d17a84b2b532f33853102168 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Sep 2013 14:03:56 +0000 Subject: Disable command line globbing on MinGW compiles: this saves startup time, since the result of the glob is not used anywhere. --- win/tclAppInit.c | 1 + 1 file changed, 1 insertion(+) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 0edd2c3..251a610 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -24,6 +24,7 @@ extern Tcl_PackageInitProc TclObjTest_Init; #endif /* TCL_TEST */ #if defined(__GNUC__) +int _CRT_glob = 0; static void setargv(int *argcPtr, char ***argvPtr); #endif /* __GNUC__ */ -- cgit v0.12 From ab9b922b76e5a364b81263128b3231b5bbd85c36 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Oct 2013 07:58:50 +0000 Subject: Fix compilation with latest MinGW-w64 version 3.0: Conflict on EXCEPTION_REGISTRATION typedef, which means something completely different in MinGW-w64. --- win/tclWin32Dll.c | 41 ++++++++++++----------------------------- win/tclWinChan.c | 29 ++++++----------------------- win/tclWinFCmd.c | 43 ++++++++++++------------------------------- win/tclWinInt.h | 17 +++++++++++++++++ 4 files changed, 47 insertions(+), 83 deletions(-) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 6c863b9..2cb7d7c 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -46,23 +46,6 @@ typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule); static HINSTANCE hInstance; /* HINSTANCE of this DLL. */ static int platformId; /* Running under NT, or 95/98? */ -#ifdef HAVE_NO_SEH -/* - * Unlike Borland and Microsoft, we don't register exception handlers by - * pushing registration records onto the runtime stack. Instead, we register - * them by creating an EXCEPTION_REGISTRATION within the activation record. - */ - -typedef struct EXCEPTION_REGISTRATION { - struct EXCEPTION_REGISTRATION *link; - EXCEPTION_DISPOSITION (*handler)( - struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); - void *ebp; - void *esp; - int status; -} EXCEPTION_REGISTRATION; -#endif - /* * VC++ 5.x has no 'cpuid' assembler instruction, so we must emulate it */ @@ -302,7 +285,7 @@ DllMain( LPVOID reserved) /* Not used. */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) - EXCEPTION_REGISTRATION registration; + TCLEXCEPTION_REGISTRATION registration; #endif switch (reason) { @@ -321,7 +304,7 @@ DllMain( __asm__ __volatile__ ( /* - * Construct an EXCEPTION_REGISTRATION to protect the call to + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to * Tcl_Finalize */ @@ -335,7 +318,7 @@ DllMain( "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* - * Link the EXCEPTION_REGISTRATION on the chain + * Link the TCLEXCEPTION_REGISTRATION on the chain */ "movl %%edx, %%fs:0" "\n\t" @@ -347,7 +330,7 @@ DllMain( "call _Tcl_Finalize" "\n\t" /* - * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION + * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION * and store a TCL_OK status */ @@ -357,7 +340,7 @@ DllMain( "jmp 2f" "\n" /* - * Come here on an exception. Get the EXCEPTION_REGISTRATION that + * Come here on an exception. Get the TCLEXCEPTION_REGISTRATION that * we previously put on the chain. */ @@ -368,7 +351,7 @@ DllMain( /* * Come here however we exited. Restore context from the - * EXCEPTION_REGISTRATION in case the stack is unbalanced. + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" @@ -1086,7 +1069,7 @@ TclWinCPUID( # else - EXCEPTION_REGISTRATION registration; + TCLEXCEPTION_REGISTRATION registration; /* * Execute the CPUID instruction with the given index, and store results @@ -1095,7 +1078,7 @@ TclWinCPUID( __asm__ __volatile__( /* - * Construct an EXCEPTION_REGISTRATION to protect the CPUID + * Construct an TCLEXCEPTION_REGISTRATION to protect the CPUID * instruction (early 486's don't have CPUID) */ @@ -1109,7 +1092,7 @@ TclWinCPUID( "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* - * Link the EXCEPTION_REGISTRATION on the chain + * Link the TCLEXCEPTION_REGISTRATION on the chain */ "movl %%edx, %%fs:0" "\n\t" @@ -1128,7 +1111,7 @@ TclWinCPUID( "movl %%edx, 0xc(%%edi)" "\n\t" /* - * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and + * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION and * store a TCL_OK status. */ @@ -1138,7 +1121,7 @@ TclWinCPUID( "jmp 2f" "\n" /* - * Come here on an exception. Get the EXCEPTION_REGISTRATION that we + * Come here on an exception. Get the TCLEXCEPTION_REGISTRATION that we * previously put on the chain. */ @@ -1148,7 +1131,7 @@ TclWinCPUID( /* * Come here however we exited. Restore context from the - * EXCEPTION_REGISTRATION in case the stack is unbalanced. + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 8aa2772..89d898f 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -119,23 +119,6 @@ static Tcl_ChannelType fileChannelType = { FileThreadActionProc, /* Thread action proc. */ FileTruncateProc, /* Truncate proc. */ }; - -#ifdef HAVE_NO_SEH -/* - * Unlike Borland and Microsoft, we don't register exception handlers by - * pushing registration records onto the runtime stack. Instead, we register - * them by creating an EXCEPTION_REGISTRATION within the activation record. - */ - -typedef struct EXCEPTION_REGISTRATION { - struct EXCEPTION_REGISTRATION* link; - EXCEPTION_DISPOSITION (*handler)( - struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); - void* ebp; - void* esp; - int status; -} EXCEPTION_REGISTRATION; -#endif /* *---------------------------------------------------------------------- @@ -1027,7 +1010,7 @@ Tcl_MakeFileChannel( * TCL_WRITABLE to indicate file mode. */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) - EXCEPTION_REGISTRATION registration; + TCLEXCEPTION_REGISTRATION registration; #endif char channelName[16 + TCL_INTEGER_SPACE]; Tcl_Channel channel = NULL; @@ -1108,7 +1091,7 @@ Tcl_MakeFileChannel( "movl %[dupedHandle], %%ebx" "\n\t" /* - * Construct an EXCEPTION_REGISTRATION to protect the call to + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to * CloseHandle. */ @@ -1122,7 +1105,7 @@ Tcl_MakeFileChannel( "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* - * Link the EXCEPTION_REGISTRATION on the chain. + * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" @@ -1135,7 +1118,7 @@ Tcl_MakeFileChannel( "call _CloseHandle@4" "\n\t" /* - * Come here on normal exit. Recover the EXCEPTION_REGISTRATION + * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION * and put a TRUE status return into it. */ @@ -1145,7 +1128,7 @@ Tcl_MakeFileChannel( "jmp 2f" "\n" /* - * Come here on an exception. Recover the EXCEPTION_REGISTRATION + * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION */ "1:" "\t" @@ -1154,7 +1137,7 @@ Tcl_MakeFileChannel( /* * Come here however we exited. Restore context from the - * EXCEPTION_REGISTRATION in case the stack is unbalanced. + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index d918b4a..8999831 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -67,25 +67,6 @@ CONST TclFileAttrProcs tclpFileAttrProcs[] = { {GetWinFileShortName, CannotSetAttribute}, {GetWinFileAttributes, SetWinFileAttributes}}; -#ifdef HAVE_NO_SEH - -/* - * Unlike Borland and Microsoft, we don't register exception handlers by - * pushing registration records onto the runtime stack. Instead, we register - * them by creating an EXCEPTION_REGISTRATION within the activation record. - */ - -typedef struct EXCEPTION_REGISTRATION { - struct EXCEPTION_REGISTRATION *link; - EXCEPTION_DISPOSITION (*handler)( - struct _EXCEPTION_RECORD *, void *, struct _CONTEXT *, void *); - void *ebp; - void *esp; - int status; -} EXCEPTION_REGISTRATION; - -#endif - /* * Prototype for the TraverseWinTree callback function. */ @@ -176,7 +157,7 @@ DoRenameFile( * (native). */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) - EXCEPTION_REGISTRATION registration; + TCLEXCEPTION_REGISTRATION registration; #endif DWORD srcAttr, dstAttr; int retval = -1; @@ -213,7 +194,7 @@ DoRenameFile( "movl %[nativeSrc], %%ecx" "\n\t" /* - * Construct an EXCEPTION_REGISTRATION to protect the call to + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to * MoveFile. */ @@ -227,7 +208,7 @@ DoRenameFile( "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* - * Link the EXCEPTION_REGISTRATION on the chain. + * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" @@ -242,7 +223,7 @@ DoRenameFile( "call *%%eax" "\n\t" /* - * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and + * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and * put the status return from MoveFile into it. */ @@ -251,7 +232,7 @@ DoRenameFile( "jmp 2f" "\n" /* - * Come here on an exception. Recover the EXCEPTION_REGISTRATION + * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION */ "1:" "\t" @@ -260,7 +241,7 @@ DoRenameFile( /* * Come here however we exited. Restore context from the - * EXCEPTION_REGISTRATION in case the stack is unbalanced. + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" @@ -568,7 +549,7 @@ DoCopyFile( CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) - EXCEPTION_REGISTRATION registration; + TCLEXCEPTION_REGISTRATION registration; #endif int retval = -1; @@ -605,7 +586,7 @@ DoCopyFile( "movl %[nativeSrc], %%ecx" "\n\t" /* - * Construct an EXCEPTION_REGISTRATION to protect the call to + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to * CopyFile. */ @@ -619,7 +600,7 @@ DoCopyFile( "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* - * Link the EXCEPTION_REGISTRATION on the chain. + * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" @@ -635,7 +616,7 @@ DoCopyFile( "call *%%eax" "\n\t" /* - * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and + * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and * put the status return from CopyFile into it. */ @@ -644,7 +625,7 @@ DoCopyFile( "jmp 2f" "\n" /* - * Come here on an exception. Recover the EXCEPTION_REGISTRATION + * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION */ "1:" "\t" @@ -653,7 +634,7 @@ DoCopyFile( /* * Come here however we exited. Restore context from the - * EXCEPTION_REGISTRATION in case the stack is unbalanced. + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 2f6659c..3d5e275 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -14,6 +14,23 @@ #include "tclInt.h" +#ifdef HAVE_NO_SEH +/* + * Unlike Borland and Microsoft, we don't register exception handlers by + * pushing registration records onto the runtime stack. Instead, we register + * them by creating an TCLEXCEPTION_REGISTRATION within the activation record. + */ + +typedef struct TCLEXCEPTION_REGISTRATION { + struct TCLEXCEPTION_REGISTRATION *link; + EXCEPTION_DISPOSITION (*handler)( + struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); + void *ebp; + void *esp; + int status; +} TCLEXCEPTION_REGISTRATION; +#endif + /* * The following specifies how much stack space TclpCheckStackSpace() * ensures is available. TclpCheckStackSpace() is called by Tcl_EvalObj() -- cgit v0.12 From b43170300d1edfb68bdc87f81aa4399d909177ee 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 6671b7930273fc4c18dedbe929e2f3d67e1dedf0 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 09:41:01 +0000 Subject: Fix TclOO API export rules. --- generic/tclOO.decls | 1 - generic/tclOO.h | 33 ++++++++++++----------- generic/tclOODecls.h | 72 +++++++++++++++++++++++++++++-------------------- generic/tclOOIntDecls.h | 46 ++++++++++++++++++++----------- 4 files changed, 91 insertions(+), 61 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index f22390e..4f1987c 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -12,7 +12,6 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. library tclOO -scspec TCLOOAPI ###################################################################### # Public API, exposed for general users of TclOO. diff --git a/generic/tclOO.h b/generic/tclOO.h index d5ab8a0..4a6cda7 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -12,21 +12,6 @@ #ifndef TCLOO_H_INCLUDED #define TCLOO_H_INCLUDED -#include "tcl.h" - -#ifndef TCLOOAPI -# if defined(BUILD_tcl) || defined(BUILD_TclOO) -# define TCLOOAPI MODULE_SCOPE -# else -# define TCLOOAPI extern -# undef USE_TCLOO_STUBS -# define USE_TCLOO_STUBS 1 -# endif -#endif - -extern const char *TclOOInitializeStubs( - Tcl_Interp *, const char *version); -#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp), TCLOO_VERSION) /* * Be careful when it comes to versioning; need to make sure that the @@ -42,6 +27,21 @@ extern const char *TclOOInitializeStubs( #define TCLOO_VERSION "1.0.1" #define TCLOO_PATCHLEVEL TCLOO_VERSION +#include "tcl.h" + +/* + * For C++ compilers, use extern "C" + */ + +#ifdef __cplusplus +extern "C" { +#endif + +extern const char *TclOOInitializeStubs( + Tcl_Interp *, const char *version); +#define Tcl_OOInitStubs(interp) \ + TclOOInitializeStubs((interp), TCLOO_VERSION) + /* * These are opaque types. */ @@ -130,6 +130,9 @@ typedef struct { #include "tclOODecls.h" +#ifdef __cplusplus +} +#endif #endif /* diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 58871c6..c2a5615 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -5,6 +5,17 @@ #ifndef _TCLOODECLS #define _TCLOODECLS +#undef TCL_STORAGE_CLASS +#ifdef BUILD_tcl +# define TCL_STORAGE_CLASS DLLEXPORT +#else +# ifdef USE_TCL_STUBS +# define TCL_STORAGE_CLASS +# else +# define TCL_STORAGE_CLASS DLLIMPORT +# endif +#endif + /* !BEGIN!: Do not edit below this line. */ /* @@ -12,92 +23,92 @@ */ /* 0 */ -TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); +EXTERN int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, +EXTERN int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); +EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); +EXTERN int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -TCLOOAPI int Tcl_ObjectContextIsFiltering( +EXTERN int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -TCLOOAPI int Tcl_ObjectContextSkippedArgs( +EXTERN int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, +EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, +EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { @@ -215,4 +226,7 @@ extern const TclOOStubs *tclOOStubsPtr; #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLOODECLS */ diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index acafb18..f0e3ee5 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -5,6 +5,17 @@ #ifndef _TCLOOINTDECLS #define _TCLOOINTDECLS +#undef TCL_STORAGE_CLASS +#ifdef BUILD_tcl +# define TCL_STORAGE_CLASS DLLEXPORT +#else +# ifdef USE_TCL_STUBS +# define TCL_STORAGE_CLASS +# else +# define TCL_STORAGE_CLASS DLLIMPORT +# endif +#endif + /* !BEGIN!: Do not edit below this line. */ /* @@ -12,46 +23,46 @@ */ /* 0 */ -TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); +EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -60,7 +71,7 @@ TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -69,22 +80,22 @@ TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, +EXTERN int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, +EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, +EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, +EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, +EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); @@ -160,4 +171,7 @@ extern const TclOOIntStubs *tclOOIntStubsPtr; #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLOOINTDECLS */ -- cgit v0.12 From 0bb601dd7253b545f4f9723a05bdd71c23421c77 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 10:01:50 +0000 Subject: Turn Tcl_OOInitStubs into a no-op in non-stub-enabled usage. --- generic/tclOO.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclOO.h b/generic/tclOO.h index 4a6cda7..e5ed10d 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,10 +37,14 @@ extern "C" { #endif +#ifdef USE_TCLOO_STUBS extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) \ TclOOInitializeStubs((interp), TCLOO_VERSION) +#else +#define Tcl_OOInitStubs(interp) (TCL_OK) +#endif /* * These are opaque types. -- cgit v0.12 From 497f593fcdae942fd1be5b1f8c9b6bfa22b77b97 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Oct 2013 10:30:19 +0000 Subject: Fix compilation of Itcl and Tdbc --- generic/tclOO.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclOO.h b/generic/tclOO.h index e5ed10d..b77faf4 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,6 +37,10 @@ extern "C" { #endif +#ifdef USE_TCL_STUBS +# define USE_TCLOO_STUBS +#endif + #ifdef USE_TCLOO_STUBS extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); -- cgit v0.12 From 1153158b42de547b96903291c168db993b64d960 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 13:14:29 +0000 Subject: silence warnings with clang --- generic/tclExecute.c | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0ca393b..fd91bdb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -293,12 +293,14 @@ VarHashCreateVar( switch (nCleanup) { \ case 1: goto cleanup1_pushObjResultPtr; \ case 2: goto cleanup2_pushObjResultPtr; \ + case 0: break; \ } \ } else { \ pc += (pcAdjustment); \ switch (nCleanup) { \ case 1: goto cleanup1; \ case 2: goto cleanup2; \ + case 0: break; \ } \ } \ } while (0) @@ -360,6 +362,8 @@ VarHashCreateVar( #define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr)) +#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) + /* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is @@ -451,7 +455,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ @@ -471,7 +475,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #endif /* TCL_WIDE_INT_IS_LONG */ @@ -885,7 +889,7 @@ TclCreateExecEnv( esPtr->nextPtr = NULL; esPtr->markerPtr = NULL; esPtr->endPtr = &esPtr->stackWords[size-1]; - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); if (!execInitialized) { @@ -1106,8 +1110,8 @@ GrowEvaluationStack( if (esPtr->nextPtr) { oldPtr = esPtr; esPtr = oldPtr->nextPtr; - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) { + currElems = esPtr->endPtr - STACK_BASE(esPtr); + if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) { Tcl_Panic("STACK: Stack after current is in use"); } if (esPtr->nextPtr) { @@ -1119,7 +1123,7 @@ GrowEvaluationStack( DeleteExecStack(esPtr); esPtr = oldPtr; } else { - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; + currElems = esPtr->endPtr - STACK_BASE(esPtr); } /* @@ -1273,10 +1277,10 @@ TclStackFree( while (esPtr->nextPtr) { esPtr = esPtr->nextPtr; } - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); while (esPtr->prevPtr) { ExecStack *tmpPtr = esPtr->prevPtr; - if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) { + if (tmpPtr->tosPtr == STACK_BASE(tmpPtr)) { DeleteExecStack(tmpPtr); } else { break; -- cgit v0.12 From 08c51736454ed20f4975179188a837a41f8f9d15 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 13:16:10 +0000 Subject: neater --- generic/tclOO.h | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/generic/tclOO.h b/generic/tclOO.h index b77faf4..e19510d 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,11 +37,7 @@ extern "C" { #endif -#ifdef USE_TCL_STUBS -# define USE_TCLOO_STUBS -#endif - -#ifdef USE_TCLOO_STUBS +#if (defined(USE_TCLOO_STUBS) || defined(USE_TCL_STUBS)) extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) \ -- cgit v0.12 From 5871b801b3da2d89d15ea3d66bcb3b216f7584fe Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 14:35:30 +0000 Subject: minor: whitespace correction (my bad!) --- generic/tclExecute.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fd91bdb..d3c1227 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -455,7 +455,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ @@ -475,7 +475,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #endif /* TCL_WIDE_INT_IS_LONG */ -- cgit v0.12 From f9427cdbfd828dbabe79facdc3d757146c090563 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 c09ca7b7b75b5cd4ce31f726e74fcfdbf011b255 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 3 Oct 2013 15:17:43 +0000 Subject: When compiling with MSVC++, no longer link the stub library with msvcrt??.dll. This way, workarounds in extensions like [http://core.tcl.tk/itcl/info/a961f0729c] are no longer necessary. --- win/Makefile.in | 2 +- win/configure | 11 +++++++---- win/configure.in | 1 + win/makefile.vc | 2 +- win/tcl.m4 | 8 +++++--- 5 files changed, 15 insertions(+), 9 deletions(-) diff --git a/win/Makefile.in b/win/Makefile.in index 6748f1b..2d97807 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -418,7 +418,7 @@ $(CAT32): cat32.$(OBJEXT) ${TCL_STUB_LIB_FILE}: ${STUB_OBJS} @$(RM) ${TCL_STUB_LIB_FILE} - @MAKE_LIB@ ${STUB_OBJS} + @MAKE_STUB_LIB@ ${STUB_OBJS} @POST_MAKE_LIB@ ${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) diff --git a/win/configure b/win/configure index 8e1d0e8..a997ac9 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 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_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. @@ -3519,6 +3519,7 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 RC_DEFINE=--define RES=res.o MAKE_LIB="\${STLIB_LD} \$@" + MAKE_STUB_LIB="\${STLIB_LD} \$@" POST_MAKE_LIB="\${RANLIB} \$@" MAKE_EXE="\${CC} -o \$@" LIBPREFIX="lib" @@ -3549,9 +3550,8 @@ echo "$as_me: error: ${CC} does not support the -shared option. runtime= # Link with gcc since ld does not link to default libs like - # -luser32 and -lmsvcrt by default. Make sure CFLAGS is - # included so -mno-cygwin passed the correct libs to the linker. - SHLIB_LD='${CC} -shared ${CFLAGS}' + # -luser32 and -lmsvcrt by default. + SHLIB_LD='${CC} -shared' SHLIB_LD_LIBS='${LIBS}' # Add SHLIB_LD_LIBS to the Make rule, not here. MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \ @@ -3932,6 +3932,7 @@ _ACEOF RC_DEFINE=-d RES=res MAKE_LIB="\${STLIB_LD} -out:\$@" + MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\$@" POST_MAKE_LIB= MAKE_EXE="\${CC} -Fe\$@" LIBPREFIX="" @@ -4881,6 +4882,7 @@ fi + # empty on win, but needs sub'ing @@ -5613,6 +5615,7 @@ s,@LIBSUFFIX@,$LIBSUFFIX,;t t s,@EXESUFFIX@,$EXESUFFIX,;t t s,@LIBRARIES@,$LIBRARIES,;t t s,@MAKE_LIB@,$MAKE_LIB,;t t +s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t s,@POST_MAKE_LIB@,$POST_MAKE_LIB,;t t s,@MAKE_DLL@,$MAKE_DLL,;t t s,@MAKE_EXE@,$MAKE_EXE,;t t diff --git a/win/configure.in b/win/configure.in index ea25843..8b181f8 100644 --- a/win/configure.in +++ b/win/configure.in @@ -305,6 +305,7 @@ AC_SUBST(LIBSUFFIX) AC_SUBST(EXESUFFIX) AC_SUBST(LIBRARIES) AC_SUBST(MAKE_LIB) +AC_SUBST(MAKE_STUB_LIB) AC_SUBST(POST_MAKE_LIB) AC_SUBST(MAKE_DLL) AC_SUBST(MAKE_EXE) diff --git a/win/makefile.vc b/win/makefile.vc index 3d17331..d9570b9 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -574,7 +574,7 @@ $** !endif $(TCLSTUBLIB): $(TCLSTUBOBJS) - $(lib32) -nologo $(LINKERFLAGS) -out:$@ $(TCLSTUBOBJS) + $(lib32) -nologo $(LINKERFLAGS) -nodefaultlib -out:$@ $(TCLSTUBOBJS) $(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** diff --git a/win/tcl.m4 b/win/tcl.m4 index 7de3013..44fd47e 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -523,6 +523,7 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [ # RES # # MAKE_LIB +# MAKE_STUB_LIB # MAKE_EXE # MAKE_DLL # @@ -663,6 +664,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ RC_DEFINE=--define RES=res.o MAKE_LIB="\${STLIB_LD} \[$]@" + MAKE_STUB_LIB="\${STLIB_LD} \[$]@" POST_MAKE_LIB="\${RANLIB} \[$]@" MAKE_EXE="\${CC} -o \[$]@" LIBPREFIX="lib" @@ -688,9 +690,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ runtime= # Link with gcc since ld does not link to default libs like - # -luser32 and -lmsvcrt by default. Make sure CFLAGS is - # included so -mno-cygwin passed the correct libs to the linker. - SHLIB_LD='${CC} -shared ${CFLAGS}' + # -luser32 and -lmsvcrt by default. + SHLIB_LD='${CC} -shared' SHLIB_LD_LIBS='${LIBS}' # Add SHLIB_LD_LIBS to the Make rule, not here. MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \ @@ -948,6 +949,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ RC_DEFINE=-d RES=res MAKE_LIB="\${STLIB_LD} -out:\[$]@" + MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\[$]@" POST_MAKE_LIB= MAKE_EXE="\${CC} -Fe\[$]@" LIBPREFIX="" -- cgit v0.12 From 84ae9beda9265b2eea4f1c06d39e10cabc760103 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 4 Oct 2013 13:12:22 +0000 Subject: Added missing documentation. Corrected result of Tcl_OOInitStubs in non-stub case. --- doc/OOInitStubs.3 | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOO.h | 2 +- 2 files changed, 55 insertions(+), 1 deletion(-) create mode 100644 doc/OOInitStubs.3 diff --git a/doc/OOInitStubs.3 b/doc/OOInitStubs.3 new file mode 100644 index 0000000..be531c8 --- /dev/null +++ b/doc/OOInitStubs.3 @@ -0,0 +1,54 @@ +'\" +'\" Copyright (c) 2012 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.so man.macros +.TH Tcl_OOInitStubs 3 1.0 TclOO "TclOO Library Functions" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_OOInitStubs \- initialize library access to TclOO functionality +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +const char * +\fBTcl_OOInitStubs\fR(\fIinterp\fR) +.fi +.SH ARGUMENTS +.AS Tcl_Interp *interp in +.AP Tcl_Interp *interp in +The Tcl interpreter that the TclOO API is integrated with and whose C +interface is going to be used. +.BE +.SH DESCRIPTION +.PP +When an extension library is going to use the C interface exposed by TclOO, it +should use \fBTcl_OOInitStubs\fR to initialize its access to that interface +from within its \fI*\fB_Init\fR (or \fI*\fB_SafeInit\fR) function, passing in +the \fIinterp\fR that was passed into that routine as context. If the result +of calling \fBTcl_OOInitStubs\fR is NULL, the initialization failed and an +error message will have been left in the interpreter's result. Otherwise, the +initialization succeeded and the TclOO API may thereafter be used; the +version of the TclOO API is returned. +.PP +When using this function, either the C #define symbol \fBUSE_TCLOO_STUBS\fR +should be defined and your library code linked against the Tcl stub library, +or that #define symbol should \fInot\fR be defined and your library code +linked against the Tcl main library directly. +.SH "BACKWARD COMPATIBILITY NOTE" +.PP +If you are linking against the Tcl 8.5 forward compatibility package for +TclOO, \fIonly\fR the stub-enabled configuration is supported and you should +also link against the TclOO independent stub library; that library is an +integrated part of the main Tcl stub library in Tcl 8.6. +.SH KEYWORDS +stubs +.SH "SEE ALSO" +Tcl_InitStubs(3) +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/generic/tclOO.h b/generic/tclOO.h index e19510d..41be168 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -43,7 +43,7 @@ extern const char *TclOOInitializeStubs( #define Tcl_OOInitStubs(interp) \ TclOOInitializeStubs((interp), TCLOO_VERSION) #else -#define Tcl_OOInitStubs(interp) (TCL_OK) +#define Tcl_OOInitStubs(interp) (TCLOO_PATCHLEVEL) #endif /* -- cgit v0.12 From bf332fb49405c13e2d003ac1b447bae2ac4291b4 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 6a229b9d227ed7356d5a8e0ba52b84a213ec7563 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 5 Oct 2013 16:22:16 +0000 Subject: Advance to tzdata2013g --- library/tzdata/Africa/Casablanca | 284 ++++++++++++------------------ library/tzdata/Africa/Juba | 40 +---- library/tzdata/America/Anguilla | 7 +- library/tzdata/America/Araguaina | 174 +----------------- library/tzdata/America/Argentina/San_Luis | 2 +- library/tzdata/America/Aruba | 8 +- library/tzdata/America/Cayman | 4 +- library/tzdata/America/Dominica | 7 +- library/tzdata/America/Grand_Turk | 4 +- library/tzdata/America/Grenada | 7 +- library/tzdata/America/Guadeloupe | 7 +- library/tzdata/America/Jamaica | 6 +- library/tzdata/America/Marigot | 6 +- library/tzdata/America/Montserrat | 7 +- library/tzdata/America/St_Barthelemy | 6 +- library/tzdata/America/St_Kitts | 7 +- library/tzdata/America/St_Lucia | 8 +- library/tzdata/America/St_Thomas | 7 +- library/tzdata/America/St_Vincent | 8 +- library/tzdata/America/Tortola | 7 +- library/tzdata/America/Virgin | 6 +- library/tzdata/Antarctica/McMurdo | 258 +-------------------------- library/tzdata/Antarctica/South_Pole | 6 +- library/tzdata/Asia/Amman | 175 +----------------- library/tzdata/Asia/Dili | 2 +- library/tzdata/Asia/Gaza | 174 +++++++++--------- library/tzdata/Asia/Hebron | 174 +++++++++--------- library/tzdata/Asia/Jakarta | 12 +- library/tzdata/Asia/Jayapura | 4 +- library/tzdata/Asia/Makassar | 4 +- library/tzdata/Asia/Pontianak | 12 +- library/tzdata/Europe/Vaduz | 246 +------------------------- library/tzdata/Europe/Zurich | 4 +- library/tzdata/Pacific/Fiji | 78 ++++---- library/tzdata/Pacific/Johnston | 6 +- 35 files changed, 413 insertions(+), 1354 deletions(-) diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 757007c..dec2778 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -36,189 +36,133 @@ set TZData(:Africa/Casablanca) { {1367114400 3600 1 WEST} {1373162400 0 0 WET} {1376100000 3600 1 WEST} - {1380420000 0 0 WET} - {1398564000 3600 1 WEST} + {1382839200 0 0 WET} + {1396144800 3600 1 WEST} {1404007200 0 0 WET} {1406599200 3600 1 WEST} - {1411869600 0 0 WET} - {1430013600 3600 1 WEST} + {1414288800 0 0 WET} + {1427594400 3600 1 WEST} {1434592800 0 0 WET} {1437184800 3600 1 WEST} - {1443319200 0 0 WET} - {1461463200 3600 1 WEST} + {1445738400 0 0 WET} + {1459044000 3600 1 WEST} {1465264800 0 0 WET} {1467856800 3600 1 WEST} - {1474768800 0 0 WET} - {1493517600 3600 1 WEST} + {1477792800 0 0 WET} + {1490493600 3600 1 WEST} {1495850400 0 0 WET} {1498442400 3600 1 WEST} - {1506218400 0 0 WET} - {1524967200 3600 1 WEST} + {1509242400 0 0 WET} + {1521943200 3600 1 WEST} {1526436000 0 0 WET} {1529028000 3600 1 WEST} - {1538272800 0 0 WET} - {1556416800 3600 1 WEST} + {1540692000 0 0 WET} + {1553997600 3600 1 WEST} {1557108000 0 0 WET} {1559700000 3600 1 WEST} - {1569722400 0 0 WET} + {1572141600 0 0 WET} + {1585447200 3600 1 WEST} + {1587693600 0 0 WET} {1590285600 3600 1 WEST} - {1601172000 0 0 WET} + {1603591200 0 0 WET} + {1616896800 3600 1 WEST} + {1618279200 0 0 WET} {1620871200 3600 1 WEST} - {1632621600 0 0 WET} + {1635645600 0 0 WET} + {1648346400 3600 1 WEST} + {1648951200 0 0 WET} {1651543200 3600 1 WEST} - {1664071200 0 0 WET} - {1682820000 3600 1 WEST} - {1695520800 0 0 WET} - {1714269600 3600 1 WEST} - {1727575200 0 0 WET} - {1745719200 3600 1 WEST} - {1759024800 0 0 WET} - {1777168800 3600 1 WEST} - {1790474400 0 0 WET} - {1808618400 3600 1 WEST} - {1821924000 0 0 WET} - {1840672800 3600 1 WEST} - {1853373600 0 0 WET} - {1872122400 3600 1 WEST} - {1885428000 0 0 WET} - {1903572000 3600 1 WEST} - {1916877600 0 0 WET} - {1935021600 3600 1 WEST} - {1948327200 0 0 WET} - {1966471200 3600 1 WEST} - {1979776800 0 0 WET} - {1997920800 3600 1 WEST} - {2011226400 0 0 WET} - {2029975200 3600 1 WEST} - {2042676000 0 0 WET} - {2061424800 3600 1 WEST} - {2074730400 0 0 WET} - {2092874400 3600 1 WEST} - {2106180000 0 0 WET} - {2124324000 3600 1 WEST} - {2137629600 0 0 WET} - {2155773600 3600 1 WEST} - {2169079200 0 0 WET} - {2187223200 3600 1 WEST} - {2200528800 0 0 WET} - {2219277600 3600 1 WEST} - {2232583200 0 0 WET} - {2250727200 3600 1 WEST} - {2264032800 0 0 WET} - {2282176800 3600 1 WEST} - {2295482400 0 0 WET} - {2313626400 3600 1 WEST} - {2326932000 0 0 WET} - {2345076000 3600 1 WEST} - {2358381600 0 0 WET} - {2377130400 3600 1 WEST} - {2389831200 0 0 WET} - {2408580000 3600 1 WEST} - {2421885600 0 0 WET} - {2440029600 3600 1 WEST} - {2453335200 0 0 WET} - {2471479200 3600 1 WEST} - {2484784800 0 0 WET} - {2502928800 3600 1 WEST} - {2516234400 0 0 WET} - {2534378400 3600 1 WEST} - {2547684000 0 0 WET} - {2566432800 3600 1 WEST} - {2579133600 0 0 WET} - {2597882400 3600 1 WEST} - {2611188000 0 0 WET} - {2629332000 3600 1 WEST} - {2642637600 0 0 WET} - {2660781600 3600 1 WEST} - {2674087200 0 0 WET} - {2692231200 3600 1 WEST} - {2705536800 0 0 WET} - {2724285600 3600 1 WEST} - {2736986400 0 0 WET} - {2755735200 3600 1 WEST} - {2769040800 0 0 WET} - {2787184800 3600 1 WEST} - {2800490400 0 0 WET} - {2818634400 3600 1 WEST} - {2831940000 0 0 WET} - {2850084000 3600 1 WEST} - {2863389600 0 0 WET} - {2881533600 3600 1 WEST} - {2894839200 0 0 WET} - {2913588000 3600 1 WEST} - {2926288800 0 0 WET} - {2945037600 3600 1 WEST} - {2958343200 0 0 WET} - {2976487200 3600 1 WEST} - {2989792800 0 0 WET} - {3007936800 3600 1 WEST} - {3021242400 0 0 WET} - {3039386400 3600 1 WEST} - {3052692000 0 0 WET} - {3070836000 3600 1 WEST} - {3084141600 0 0 WET} - {3102890400 3600 1 WEST} - {3116196000 0 0 WET} - {3134340000 3600 1 WEST} - {3147645600 0 0 WET} - {3165789600 3600 1 WEST} - {3179095200 0 0 WET} - {3197239200 3600 1 WEST} - {3210544800 0 0 WET} - {3228688800 3600 1 WEST} - {3241994400 0 0 WET} - {3260743200 3600 1 WEST} - {3273444000 0 0 WET} - {3292192800 3600 1 WEST} - {3305498400 0 0 WET} - {3323642400 3600 1 WEST} - {3336948000 0 0 WET} - {3355092000 3600 1 WEST} - {3368397600 0 0 WET} - {3386541600 3600 1 WEST} - {3399847200 0 0 WET} - {3417991200 3600 1 WEST} - {3431296800 0 0 WET} - {3450045600 3600 1 WEST} - {3462746400 0 0 WET} - {3481495200 3600 1 WEST} - {3494800800 0 0 WET} - {3512944800 3600 1 WEST} - {3526250400 0 0 WET} - {3544394400 3600 1 WEST} - {3557700000 0 0 WET} - {3575844000 3600 1 WEST} - {3589149600 0 0 WET} - {3607898400 3600 1 WEST} - {3620599200 0 0 WET} - {3639348000 3600 1 WEST} - {3652653600 0 0 WET} - {3670797600 3600 1 WEST} - {3684103200 0 0 WET} - {3702247200 3600 1 WEST} - {3715552800 0 0 WET} - {3733696800 3600 1 WEST} - {3747002400 0 0 WET} - {3765146400 3600 1 WEST} - {3778452000 0 0 WET} - {3797200800 3600 1 WEST} - {3809901600 0 0 WET} - {3828650400 3600 1 WEST} - {3841956000 0 0 WET} - {3860100000 3600 1 WEST} - {3873405600 0 0 WET} - {3891549600 3600 1 WEST} - {3904855200 0 0 WET} - {3922999200 3600 1 WEST} - {3936304800 0 0 WET} - {3954448800 3600 1 WEST} - {3967754400 0 0 WET} - {3986503200 3600 1 WEST} - {3999808800 0 0 WET} - {4017952800 3600 1 WEST} - {4031258400 0 0 WET} - {4049402400 3600 1 WEST} - {4062708000 0 0 WET} - {4080852000 3600 1 WEST} - {4094157600 0 0 WET} + {1667095200 0 0 WET} + {1682128800 3600 1 WEST} + {1698544800 0 0 WET} + {1712714400 3600 1 WEST} + {1729994400 0 0 WET} + {1743386400 3600 1 WEST} + {1761444000 0 0 WET} + {1774749600 3600 1 WEST} + {1792893600 0 0 WET} + {1806199200 3600 1 WEST} + {1824948000 0 0 WET} + {1837648800 3600 1 WEST} + {1856397600 0 0 WET} + {1869098400 3600 1 WEST} + {1887847200 0 0 WET} + {1901152800 3600 1 WEST} + {1919296800 0 0 WET} + {1932602400 3600 1 WEST} + {1950746400 0 0 WET} + {1964052000 3600 1 WEST} + {1982800800 0 0 WET} + {1995501600 3600 1 WEST} + {2014250400 0 0 WET} + {2026951200 3600 1 WEST} + {2045700000 0 0 WET} + {2058400800 3600 1 WEST} + {2077149600 0 0 WET} + {2090455200 3600 1 WEST} + {2108167200 0 0 WET} + {2121904800 3600 1 WEST} + {2138839200 0 0 WET} + {2153354400 3600 1 WEST} + {2184800400 3600 1 WEST} + {2216250000 3600 1 WEST} + {2248304400 3600 1 WEST} + {2279754000 3600 1 WEST} + {2311203600 3600 1 WEST} + {2342653200 3600 1 WEST} + {2374102800 3600 1 WEST} + {2405552400 3600 1 WEST} + {2437606800 3600 1 WEST} + {2469056400 3600 1 WEST} + {2500506000 3600 1 WEST} + {2531955600 3600 1 WEST} + {2563405200 3600 1 WEST} + {2595459600 3600 1 WEST} + {2626909200 3600 1 WEST} + {2658358800 3600 1 WEST} + {2689808400 3600 1 WEST} + {2721258000 3600 1 WEST} + {2752707600 3600 1 WEST} + {2784762000 3600 1 WEST} + {2816211600 3600 1 WEST} + {2847661200 3600 1 WEST} + {2879110800 3600 1 WEST} + {2910560400 3600 1 WEST} + {2942010000 3600 1 WEST} + {2974064400 3600 1 WEST} + {3005514000 3600 1 WEST} + {3036963600 3600 1 WEST} + {3068413200 3600 1 WEST} + {3099862800 3600 1 WEST} + {3131917200 3600 1 WEST} + {3163366800 3600 1 WEST} + {3194816400 3600 1 WEST} + {3226266000 3600 1 WEST} + {3257715600 3600 1 WEST} + {3289165200 3600 1 WEST} + {3321219600 3600 1 WEST} + {3352669200 3600 1 WEST} + {3384118800 3600 1 WEST} + {3415568400 3600 1 WEST} + {3447018000 3600 1 WEST} + {3479072400 3600 1 WEST} + {3510522000 3600 1 WEST} + {3541971600 3600 1 WEST} + {3573421200 3600 1 WEST} + {3604870800 3600 1 WEST} + {3636320400 3600 1 WEST} + {3668374800 3600 1 WEST} + {3699824400 3600 1 WEST} + {3731274000 3600 1 WEST} + {3762723600 3600 1 WEST} + {3794173200 3600 1 WEST} + {3825622800 3600 1 WEST} + {3857677200 3600 1 WEST} + {3889126800 3600 1 WEST} + {3920576400 3600 1 WEST} + {3952026000 3600 1 WEST} + {3983475600 3600 1 WEST} + {4015530000 3600 1 WEST} + {4046979600 3600 1 WEST} + {4078429200 3600 1 WEST} } diff --git a/library/tzdata/Africa/Juba b/library/tzdata/Africa/Juba index 7495981..40551f2 100644 --- a/library/tzdata/Africa/Juba +++ b/library/tzdata/Africa/Juba @@ -1,39 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Africa/Juba) { - {-9223372036854775808 7584 0 LMT} - {-1230775584 7200 0 CAT} - {10360800 10800 1 CAST} - {24786000 7200 0 CAT} - {41810400 10800 1 CAST} - {56322000 7200 0 CAT} - {73432800 10800 1 CAST} - {87944400 7200 0 CAT} - {104882400 10800 1 CAST} - {119480400 7200 0 CAT} - {136332000 10800 1 CAST} - {151016400 7200 0 CAT} - {167781600 10800 1 CAST} - {182552400 7200 0 CAT} - {199231200 10800 1 CAST} - {214174800 7200 0 CAT} - {230680800 10800 1 CAST} - {245710800 7200 0 CAT} - {262735200 10800 1 CAST} - {277246800 7200 0 CAT} - {294184800 10800 1 CAST} - {308782800 7200 0 CAT} - {325634400 10800 1 CAST} - {340405200 7200 0 CAT} - {357084000 10800 1 CAST} - {371941200 7200 0 CAT} - {388533600 10800 1 CAST} - {403477200 7200 0 CAT} - {419983200 10800 1 CAST} - {435013200 7200 0 CAT} - {452037600 10800 1 CAST} - {466635600 7200 0 CAT} - {483487200 10800 1 CAST} - {498171600 7200 0 CAT} - {947930400 10800 0 EAT} +if {![info exists TZData(Africa/Khartoum)]} { + LoadTimeZoneFile Africa/Khartoum } +set TZData(:Africa/Juba) $TZData(:Africa/Khartoum) diff --git a/library/tzdata/America/Anguilla b/library/tzdata/America/Anguilla index cfe7483..39a0d18 100644 --- a/library/tzdata/America/Anguilla +++ b/library/tzdata/America/Anguilla @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Anguilla) { - {-9223372036854775808 -15136 0 LMT} - {-1825098464 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Anguilla) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Araguaina b/library/tzdata/America/Araguaina index dc1b543..e4a0d52 100644 --- a/library/tzdata/America/Araguaina +++ b/library/tzdata/America/Araguaina @@ -56,177 +56,5 @@ set TZData(:America/Araguaina) { {1064368800 -10800 0 BRT} {1350788400 -7200 0 BRST} {1361066400 -10800 0 BRT} - {1382238000 -7200 1 BRST} - {1392516000 -10800 0 BRT} - {1413687600 -7200 1 BRST} - {1424570400 -10800 0 BRT} - {1445137200 -7200 1 BRST} - {1456020000 -10800 0 BRT} - {1476586800 -7200 1 BRST} - {1487469600 -10800 0 BRT} - {1508036400 -7200 1 BRST} - {1518919200 -10800 0 BRT} - {1540090800 -7200 1 BRST} - {1550368800 -10800 0 BRT} - {1571540400 -7200 1 BRST} - {1581818400 -10800 0 BRT} - {1602990000 -7200 1 BRST} - {1613872800 -10800 0 BRT} - {1634439600 -7200 1 BRST} - {1645322400 -10800 0 BRT} - {1665889200 -7200 1 BRST} - {1677376800 -10800 0 BRT} - {1697338800 -7200 1 BRST} - {1708221600 -10800 0 BRT} - {1729393200 -7200 1 BRST} - {1739671200 -10800 0 BRT} - {1760842800 -7200 1 BRST} - {1771725600 -10800 0 BRT} - {1792292400 -7200 1 BRST} - {1803175200 -10800 0 BRT} - {1823742000 -7200 1 BRST} - {1834624800 -10800 0 BRT} - {1855191600 -7200 1 BRST} - {1866074400 -10800 0 BRT} - {1887246000 -7200 1 BRST} - {1897524000 -10800 0 BRT} - {1918695600 -7200 1 BRST} - {1928973600 -10800 0 BRT} - {1950145200 -7200 1 BRST} - {1960423200 -10800 0 BRT} - {1981594800 -7200 1 BRST} - {1992477600 -10800 0 BRT} - {2013044400 -7200 1 BRST} - {2024532000 -10800 0 BRT} - {2044494000 -7200 1 BRST} - {2055376800 -10800 0 BRT} - {2076548400 -7200 1 BRST} - {2086826400 -10800 0 BRT} - {2107998000 -7200 1 BRST} - {2118880800 -10800 0 BRT} - {2139447600 -7200 1 BRST} - {2150330400 -10800 0 BRT} - {2170897200 -7200 1 BRST} - {2181780000 -10800 0 BRT} - {2202346800 -7200 1 BRST} - {2213229600 -10800 0 BRT} - {2234401200 -7200 1 BRST} - {2244679200 -10800 0 BRT} - {2265850800 -7200 1 BRST} - {2276128800 -10800 0 BRT} - {2297300400 -7200 1 BRST} - {2307578400 -10800 0 BRT} - {2328750000 -7200 1 BRST} - {2339632800 -10800 0 BRT} - {2360199600 -7200 1 BRST} - {2371082400 -10800 0 BRT} - {2391649200 -7200 1 BRST} - {2402532000 -10800 0 BRT} - {2423703600 -7200 1 BRST} - {2433981600 -10800 0 BRT} - {2455153200 -7200 1 BRST} - {2465431200 -10800 0 BRT} - {2486602800 -7200 1 BRST} - {2497485600 -10800 0 BRT} - {2518052400 -7200 1 BRST} - {2528935200 -10800 0 BRT} - {2549502000 -7200 1 BRST} - {2560384800 -10800 0 BRT} - {2580951600 -7200 1 BRST} - {2591834400 -10800 0 BRT} - {2613006000 -7200 1 BRST} - {2623284000 -10800 0 BRT} - {2644455600 -7200 1 BRST} - {2654733600 -10800 0 BRT} - {2675905200 -7200 1 BRST} - {2686788000 -10800 0 BRT} - {2707354800 -7200 1 BRST} - {2718237600 -10800 0 BRT} - {2738804400 -7200 1 BRST} - {2749687200 -10800 0 BRT} - {2770858800 -7200 1 BRST} - {2781136800 -10800 0 BRT} - {2802308400 -7200 1 BRST} - {2812586400 -10800 0 BRT} - {2833758000 -7200 1 BRST} - {2844036000 -10800 0 BRT} - {2865207600 -7200 1 BRST} - {2876090400 -10800 0 BRT} - {2896657200 -7200 1 BRST} - {2907540000 -10800 0 BRT} - {2928106800 -7200 1 BRST} - {2938989600 -10800 0 BRT} - {2960161200 -7200 1 BRST} - {2970439200 -10800 0 BRT} - {2991610800 -7200 1 BRST} - {3001888800 -10800 0 BRT} - {3023060400 -7200 1 BRST} - {3033943200 -10800 0 BRT} - {3054510000 -7200 1 BRST} - {3065392800 -10800 0 BRT} - {3085959600 -7200 1 BRST} - {3096842400 -10800 0 BRT} - {3118014000 -7200 1 BRST} - {3128292000 -10800 0 BRT} - {3149463600 -7200 1 BRST} - {3159741600 -10800 0 BRT} - {3180913200 -7200 1 BRST} - {3191191200 -10800 0 BRT} - {3212362800 -7200 1 BRST} - {3223245600 -10800 0 BRT} - {3243812400 -7200 1 BRST} - {3254695200 -10800 0 BRT} - {3275262000 -7200 1 BRST} - {3286144800 -10800 0 BRT} - {3307316400 -7200 1 BRST} - {3317594400 -10800 0 BRT} - {3338766000 -7200 1 BRST} - {3349044000 -10800 0 BRT} - {3370215600 -7200 1 BRST} - {3381098400 -10800 0 BRT} - {3401665200 -7200 1 BRST} - {3412548000 -10800 0 BRT} - {3433114800 -7200 1 BRST} - {3443997600 -10800 0 BRT} - {3464564400 -7200 1 BRST} - {3475447200 -10800 0 BRT} - {3496618800 -7200 1 BRST} - {3506896800 -10800 0 BRT} - {3528068400 -7200 1 BRST} - {3538346400 -10800 0 BRT} - {3559518000 -7200 1 BRST} - {3570400800 -10800 0 BRT} - {3590967600 -7200 1 BRST} - {3601850400 -10800 0 BRT} - {3622417200 -7200 1 BRST} - {3633300000 -10800 0 BRT} - {3654471600 -7200 1 BRST} - {3664749600 -10800 0 BRT} - {3685921200 -7200 1 BRST} - {3696199200 -10800 0 BRT} - {3717370800 -7200 1 BRST} - {3727648800 -10800 0 BRT} - {3748820400 -7200 1 BRST} - {3759703200 -10800 0 BRT} - {3780270000 -7200 1 BRST} - {3791152800 -10800 0 BRT} - {3811719600 -7200 1 BRST} - {3822602400 -10800 0 BRT} - {3843774000 -7200 1 BRST} - {3854052000 -10800 0 BRT} - {3875223600 -7200 1 BRST} - {3885501600 -10800 0 BRT} - {3906673200 -7200 1 BRST} - {3917556000 -10800 0 BRT} - {3938122800 -7200 1 BRST} - {3949005600 -10800 0 BRT} - {3969572400 -7200 1 BRST} - {3980455200 -10800 0 BRT} - {4001626800 -7200 1 BRST} - {4011904800 -10800 0 BRT} - {4033076400 -7200 1 BRST} - {4043354400 -10800 0 BRT} - {4064526000 -7200 1 BRST} - {4074804000 -10800 0 BRT} - {4095975600 -7200 1 BRST} + {1378000800 -10800 0 BRT} } diff --git a/library/tzdata/America/Argentina/San_Luis b/library/tzdata/America/Argentina/San_Luis index bec1554..8ca55d7 100644 --- a/library/tzdata/America/Argentina/San_Luis +++ b/library/tzdata/America/Argentina/San_Luis @@ -64,5 +64,5 @@ set TZData(:America/Argentina/San_Luis) { {1205031600 -14400 0 WART} {1223784000 -10800 1 WARST} {1236481200 -14400 0 WART} - {1255233600 -10800 1 WARST} + {1255233600 -10800 0 ART} } diff --git a/library/tzdata/America/Aruba b/library/tzdata/America/Aruba index 92f182d..e02d5fc 100644 --- a/library/tzdata/America/Aruba +++ b/library/tzdata/America/Aruba @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Aruba) { - {-9223372036854775808 -16824 0 LMT} - {-1826738376 -16200 0 ANT} - {-157750200 -14400 0 AST} +if {![info exists TZData(America/Curacao)]} { + LoadTimeZoneFile America/Curacao } +set TZData(:America/Aruba) $TZData(:America/Curacao) diff --git a/library/tzdata/America/Cayman b/library/tzdata/America/Cayman index ab5d12b..3e2e3cc 100644 --- a/library/tzdata/America/Cayman +++ b/library/tzdata/America/Cayman @@ -2,6 +2,6 @@ set TZData(:America/Cayman) { {-9223372036854775808 -19532 0 LMT} - {-2524502068 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-2524502068 -18431 0 KMT} + {-1827687169 -18000 0 EST} } diff --git a/library/tzdata/America/Dominica b/library/tzdata/America/Dominica index 3503a65..b97cb0e 100644 --- a/library/tzdata/America/Dominica +++ b/library/tzdata/America/Dominica @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Dominica) { - {-9223372036854775808 -14736 0 LMT} - {-1846266804 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Dominica) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Grand_Turk b/library/tzdata/America/Grand_Turk index a455dd5..6c8ea4a 100644 --- a/library/tzdata/America/Grand_Turk +++ b/library/tzdata/America/Grand_Turk @@ -2,8 +2,8 @@ set TZData(:America/Grand_Turk) { {-9223372036854775808 -17072 0 LMT} - {-2524504528 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-2524504528 -18431 0 KMT} + {-1827687169 -18000 0 EST} {294217200 -14400 1 EDT} {309938400 -18000 0 EST} {325666800 -14400 1 EDT} diff --git a/library/tzdata/America/Grenada b/library/tzdata/America/Grenada index 3c2919b..92300c3 100644 --- a/library/tzdata/America/Grenada +++ b/library/tzdata/America/Grenada @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Grenada) { - {-9223372036854775808 -14820 0 LMT} - {-1846266780 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Grenada) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Guadeloupe b/library/tzdata/America/Guadeloupe index b1987ce..aba6bd7 100644 --- a/library/tzdata/America/Guadeloupe +++ b/library/tzdata/America/Guadeloupe @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Guadeloupe) { - {-9223372036854775808 -14768 0 LMT} - {-1848254032 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Guadeloupe) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Jamaica b/library/tzdata/America/Jamaica index 393d90a8..682e47c 100644 --- a/library/tzdata/America/Jamaica +++ b/library/tzdata/America/Jamaica @@ -1,9 +1,9 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:America/Jamaica) { - {-9223372036854775808 -18432 0 LMT} - {-2524503168 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-9223372036854775808 -18431 0 LMT} + {-2524503169 -18431 0 KMT} + {-1827687169 -18000 0 EST} {136364400 -14400 0 EDT} {152085600 -18000 0 EST} {162370800 -14400 1 EDT} diff --git a/library/tzdata/America/Marigot b/library/tzdata/America/Marigot index 9f3f8f6..c2b3873 100644 --- a/library/tzdata/America/Marigot +++ b/library/tzdata/America/Marigot @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Guadeloupe)]} { - LoadTimeZoneFile America/Guadeloupe +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/Marigot) $TZData(:America/Guadeloupe) +set TZData(:America/Marigot) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Montserrat b/library/tzdata/America/Montserrat index 4d82766..0a656d3 100644 --- a/library/tzdata/America/Montserrat +++ b/library/tzdata/America/Montserrat @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Montserrat) { - {-9223372036854775808 -14932 0 LMT} - {-1846266608 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Montserrat) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Barthelemy b/library/tzdata/America/St_Barthelemy index 25c114a..46bc287 100644 --- a/library/tzdata/America/St_Barthelemy +++ b/library/tzdata/America/St_Barthelemy @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Guadeloupe)]} { - LoadTimeZoneFile America/Guadeloupe +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/St_Barthelemy) $TZData(:America/Guadeloupe) +set TZData(:America/St_Barthelemy) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Kitts b/library/tzdata/America/St_Kitts index bfd803b..6ad7f04 100644 --- a/library/tzdata/America/St_Kitts +++ b/library/tzdata/America/St_Kitts @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Kitts) { - {-9223372036854775808 -15052 0 LMT} - {-1825098548 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Kitts) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Lucia b/library/tzdata/America/St_Lucia index c2767dd..e479b31 100644 --- a/library/tzdata/America/St_Lucia +++ b/library/tzdata/America/St_Lucia @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Lucia) { - {-9223372036854775808 -14640 0 LMT} - {-2524506960 -14640 0 CMT} - {-1830369360 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Lucia) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Thomas b/library/tzdata/America/St_Thomas index bf93595..24698b8 100644 --- a/library/tzdata/America/St_Thomas +++ b/library/tzdata/America/St_Thomas @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Thomas) { - {-9223372036854775808 -15584 0 LMT} - {-1846266016 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Thomas) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Vincent b/library/tzdata/America/St_Vincent index 3a884c7..e3b32fb 100644 --- a/library/tzdata/America/St_Vincent +++ b/library/tzdata/America/St_Vincent @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Vincent) { - {-9223372036854775808 -14696 0 LMT} - {-2524506904 -14696 0 KMT} - {-1830369304 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Vincent) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Tortola b/library/tzdata/America/Tortola index bf7f1fc..aa6f655 100644 --- a/library/tzdata/America/Tortola +++ b/library/tzdata/America/Tortola @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Tortola) { - {-9223372036854775808 -15508 0 LMT} - {-1846266092 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Tortola) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Virgin b/library/tzdata/America/Virgin index 390d7c2..c267e5b 100644 --- a/library/tzdata/America/Virgin +++ b/library/tzdata/America/Virgin @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/St_Thomas)]} { - LoadTimeZoneFile America/St_Thomas +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/Virgin) $TZData(:America/St_Thomas) +set TZData(:America/Virgin) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/Antarctica/McMurdo b/library/tzdata/Antarctica/McMurdo index 670f7eb..3b29ba1 100644 --- a/library/tzdata/Antarctica/McMurdo +++ b/library/tzdata/Antarctica/McMurdo @@ -1,257 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Antarctica/McMurdo) { - {-9223372036854775808 0 0 zzz} - {-441849600 43200 0 NZST} - {152632800 46800 1 NZDT} - {162309600 43200 0 NZST} - {183477600 46800 1 NZDT} - {194968800 43200 0 NZST} - {215532000 46800 1 NZDT} - {226418400 43200 0 NZST} - {246981600 46800 1 NZDT} - {257868000 43200 0 NZST} - {278431200 46800 1 NZDT} - {289317600 43200 0 NZST} - {309880800 46800 1 NZDT} - {320767200 43200 0 NZST} - {341330400 46800 1 NZDT} - {352216800 43200 0 NZST} - {372780000 46800 1 NZDT} - {384271200 43200 0 NZST} - {404834400 46800 1 NZDT} - {415720800 43200 0 NZST} - {436284000 46800 1 NZDT} - {447170400 43200 0 NZST} - {467733600 46800 1 NZDT} - {478620000 43200 0 NZST} - {499183200 46800 1 NZDT} - {510069600 43200 0 NZST} - {530632800 46800 1 NZDT} - {541519200 43200 0 NZST} - {562082400 46800 1 NZDT} - {573573600 43200 0 NZST} - {594136800 46800 1 NZDT} - {605023200 43200 0 NZST} - {623772000 46800 1 NZDT} - {637682400 43200 0 NZST} - {655221600 46800 1 NZDT} - {669132000 43200 0 NZST} - {686671200 46800 1 NZDT} - {700581600 43200 0 NZST} - {718120800 46800 1 NZDT} - {732636000 43200 0 NZST} - {749570400 46800 1 NZDT} - {764085600 43200 0 NZST} - {781020000 46800 1 NZDT} - {795535200 43200 0 NZST} - {812469600 46800 1 NZDT} - {826984800 43200 0 NZST} - {844524000 46800 1 NZDT} - {858434400 43200 0 NZST} - {875973600 46800 1 NZDT} - {889884000 43200 0 NZST} - {907423200 46800 1 NZDT} - {921938400 43200 0 NZST} - {938872800 46800 1 NZDT} - {953388000 43200 0 NZST} - {970322400 46800 1 NZDT} - {984837600 43200 0 NZST} - {1002376800 46800 1 NZDT} - {1016287200 43200 0 NZST} - {1033826400 46800 1 NZDT} - {1047736800 43200 0 NZST} - {1065276000 46800 1 NZDT} - {1079791200 43200 0 NZST} - {1096725600 46800 1 NZDT} - {1111240800 43200 0 NZST} - {1128175200 46800 1 NZDT} - {1142690400 43200 0 NZST} - {1159624800 46800 1 NZDT} - {1174140000 43200 0 NZST} - {1191074400 46800 1 NZDT} - {1207404000 43200 0 NZST} - {1222524000 46800 1 NZDT} - {1238853600 43200 0 NZST} - {1253973600 46800 1 NZDT} - {1270303200 43200 0 NZST} - {1285423200 46800 1 NZDT} - {1301752800 43200 0 NZST} - {1316872800 46800 1 NZDT} - {1333202400 43200 0 NZST} - {1348927200 46800 1 NZDT} - {1365256800 43200 0 NZST} - {1380376800 46800 1 NZDT} - {1396706400 43200 0 NZST} - {1411826400 46800 1 NZDT} - {1428156000 43200 0 NZST} - {1443276000 46800 1 NZDT} - {1459605600 43200 0 NZST} - {1474725600 46800 1 NZDT} - {1491055200 43200 0 NZST} - {1506175200 46800 1 NZDT} - {1522504800 43200 0 NZST} - {1538229600 46800 1 NZDT} - {1554559200 43200 0 NZST} - {1569679200 46800 1 NZDT} - {1586008800 43200 0 NZST} - {1601128800 46800 1 NZDT} - {1617458400 43200 0 NZST} - {1632578400 46800 1 NZDT} - {1648908000 43200 0 NZST} - {1664028000 46800 1 NZDT} - {1680357600 43200 0 NZST} - {1695477600 46800 1 NZDT} - {1712412000 43200 0 NZST} - {1727532000 46800 1 NZDT} - {1743861600 43200 0 NZST} - {1758981600 46800 1 NZDT} - {1775311200 43200 0 NZST} - {1790431200 46800 1 NZDT} - {1806760800 43200 0 NZST} - {1821880800 46800 1 NZDT} - {1838210400 43200 0 NZST} - {1853330400 46800 1 NZDT} - {1869660000 43200 0 NZST} - {1885384800 46800 1 NZDT} - {1901714400 43200 0 NZST} - {1916834400 46800 1 NZDT} - {1933164000 43200 0 NZST} - {1948284000 46800 1 NZDT} - {1964613600 43200 0 NZST} - {1979733600 46800 1 NZDT} - {1996063200 43200 0 NZST} - {2011183200 46800 1 NZDT} - {2027512800 43200 0 NZST} - {2042632800 46800 1 NZDT} - {2058962400 43200 0 NZST} - {2074687200 46800 1 NZDT} - {2091016800 43200 0 NZST} - {2106136800 46800 1 NZDT} - {2122466400 43200 0 NZST} - {2137586400 46800 1 NZDT} - {2153916000 43200 0 NZST} - {2169036000 46800 1 NZDT} - {2185365600 43200 0 NZST} - {2200485600 46800 1 NZDT} - {2216815200 43200 0 NZST} - {2232540000 46800 1 NZDT} - {2248869600 43200 0 NZST} - {2263989600 46800 1 NZDT} - {2280319200 43200 0 NZST} - {2295439200 46800 1 NZDT} - {2311768800 43200 0 NZST} - {2326888800 46800 1 NZDT} - {2343218400 43200 0 NZST} - {2358338400 46800 1 NZDT} - {2374668000 43200 0 NZST} - {2389788000 46800 1 NZDT} - {2406117600 43200 0 NZST} - {2421842400 46800 1 NZDT} - {2438172000 43200 0 NZST} - {2453292000 46800 1 NZDT} - {2469621600 43200 0 NZST} - {2484741600 46800 1 NZDT} - {2501071200 43200 0 NZST} - {2516191200 46800 1 NZDT} - {2532520800 43200 0 NZST} - {2547640800 46800 1 NZDT} - {2563970400 43200 0 NZST} - {2579090400 46800 1 NZDT} - {2596024800 43200 0 NZST} - {2611144800 46800 1 NZDT} - {2627474400 43200 0 NZST} - {2642594400 46800 1 NZDT} - {2658924000 43200 0 NZST} - {2674044000 46800 1 NZDT} - {2690373600 43200 0 NZST} - {2705493600 46800 1 NZDT} - {2721823200 43200 0 NZST} - {2736943200 46800 1 NZDT} - {2753272800 43200 0 NZST} - {2768997600 46800 1 NZDT} - {2785327200 43200 0 NZST} - {2800447200 46800 1 NZDT} - {2816776800 43200 0 NZST} - {2831896800 46800 1 NZDT} - {2848226400 43200 0 NZST} - {2863346400 46800 1 NZDT} - {2879676000 43200 0 NZST} - {2894796000 46800 1 NZDT} - {2911125600 43200 0 NZST} - {2926245600 46800 1 NZDT} - {2942575200 43200 0 NZST} - {2958300000 46800 1 NZDT} - {2974629600 43200 0 NZST} - {2989749600 46800 1 NZDT} - {3006079200 43200 0 NZST} - {3021199200 46800 1 NZDT} - {3037528800 43200 0 NZST} - {3052648800 46800 1 NZDT} - {3068978400 43200 0 NZST} - {3084098400 46800 1 NZDT} - {3100428000 43200 0 NZST} - {3116152800 46800 1 NZDT} - {3132482400 43200 0 NZST} - {3147602400 46800 1 NZDT} - {3163932000 43200 0 NZST} - {3179052000 46800 1 NZDT} - {3195381600 43200 0 NZST} - {3210501600 46800 1 NZDT} - {3226831200 43200 0 NZST} - {3241951200 46800 1 NZDT} - {3258280800 43200 0 NZST} - {3273400800 46800 1 NZDT} - {3289730400 43200 0 NZST} - {3305455200 46800 1 NZDT} - {3321784800 43200 0 NZST} - {3336904800 46800 1 NZDT} - {3353234400 43200 0 NZST} - {3368354400 46800 1 NZDT} - {3384684000 43200 0 NZST} - {3399804000 46800 1 NZDT} - {3416133600 43200 0 NZST} - {3431253600 46800 1 NZDT} - {3447583200 43200 0 NZST} - {3462703200 46800 1 NZDT} - {3479637600 43200 0 NZST} - {3494757600 46800 1 NZDT} - {3511087200 43200 0 NZST} - {3526207200 46800 1 NZDT} - {3542536800 43200 0 NZST} - {3557656800 46800 1 NZDT} - {3573986400 43200 0 NZST} - {3589106400 46800 1 NZDT} - {3605436000 43200 0 NZST} - {3620556000 46800 1 NZDT} - {3636885600 43200 0 NZST} - {3652610400 46800 1 NZDT} - {3668940000 43200 0 NZST} - {3684060000 46800 1 NZDT} - {3700389600 43200 0 NZST} - {3715509600 46800 1 NZDT} - {3731839200 43200 0 NZST} - {3746959200 46800 1 NZDT} - {3763288800 43200 0 NZST} - {3778408800 46800 1 NZDT} - {3794738400 43200 0 NZST} - {3809858400 46800 1 NZDT} - {3826188000 43200 0 NZST} - {3841912800 46800 1 NZDT} - {3858242400 43200 0 NZST} - {3873362400 46800 1 NZDT} - {3889692000 43200 0 NZST} - {3904812000 46800 1 NZDT} - {3921141600 43200 0 NZST} - {3936261600 46800 1 NZDT} - {3952591200 43200 0 NZST} - {3967711200 46800 1 NZDT} - {3984040800 43200 0 NZST} - {3999765600 46800 1 NZDT} - {4016095200 43200 0 NZST} - {4031215200 46800 1 NZDT} - {4047544800 43200 0 NZST} - {4062664800 46800 1 NZDT} - {4078994400 43200 0 NZST} - {4094114400 46800 1 NZDT} +if {![info exists TZData(Pacific/Auckland)]} { + LoadTimeZoneFile Pacific/Auckland } +set TZData(:Antarctica/McMurdo) $TZData(:Pacific/Auckland) diff --git a/library/tzdata/Antarctica/South_Pole b/library/tzdata/Antarctica/South_Pole index 34d0db1..544bde4 100644 --- a/library/tzdata/Antarctica/South_Pole +++ b/library/tzdata/Antarctica/South_Pole @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Antarctica/McMurdo)]} { - LoadTimeZoneFile Antarctica/McMurdo +if {![info exists TZData(Pacific/Auckland)]} { + LoadTimeZoneFile Pacific/Auckland } -set TZData(:Antarctica/South_Pole) $TZData(:Antarctica/McMurdo) +set TZData(:Antarctica/South_Pole) $TZData(:Pacific/Auckland) diff --git a/library/tzdata/Asia/Amman b/library/tzdata/Asia/Amman index 33f0ba7..d5e8616 100644 --- a/library/tzdata/Asia/Amman +++ b/library/tzdata/Asia/Amman @@ -70,178 +70,5 @@ set TZData(:Asia/Amman) { {1301608800 10800 1 EEST} {1319752800 7200 0 EET} {1333058400 10800 1 EEST} - {1364504400 10800 1 EEST} - {1382652000 7200 0 EET} - {1395957600 10800 1 EEST} - {1414706400 7200 0 EET} - {1427407200 10800 1 EEST} - {1446156000 7200 0 EET} - {1459461600 10800 1 EEST} - {1477605600 7200 0 EET} - {1490911200 10800 1 EEST} - {1509055200 7200 0 EET} - {1522360800 10800 1 EEST} - {1540504800 7200 0 EET} - {1553810400 10800 1 EEST} - {1571954400 7200 0 EET} - {1585260000 10800 1 EEST} - {1604008800 7200 0 EET} - {1616709600 10800 1 EEST} - {1635458400 7200 0 EET} - {1648764000 10800 1 EEST} - {1666908000 7200 0 EET} - {1680213600 10800 1 EEST} - {1698357600 7200 0 EET} - {1711663200 10800 1 EEST} - {1729807200 7200 0 EET} - {1743112800 10800 1 EEST} - {1761861600 7200 0 EET} - {1774562400 10800 1 EEST} - {1793311200 7200 0 EET} - {1806012000 10800 1 EEST} - {1824760800 7200 0 EET} - {1838066400 10800 1 EEST} - {1856210400 7200 0 EET} - {1869516000 10800 1 EEST} - {1887660000 7200 0 EET} - {1900965600 10800 1 EEST} - {1919109600 7200 0 EET} - {1932415200 10800 1 EEST} - {1951164000 7200 0 EET} - {1963864800 10800 1 EEST} - {1982613600 7200 0 EET} - {1995919200 10800 1 EEST} - {2014063200 7200 0 EET} - {2027368800 10800 1 EEST} - {2045512800 7200 0 EET} - {2058818400 10800 1 EEST} - {2076962400 7200 0 EET} - {2090268000 10800 1 EEST} - {2109016800 7200 0 EET} - {2121717600 10800 1 EEST} - {2140466400 7200 0 EET} - {2153167200 10800 1 EEST} - {2171916000 7200 0 EET} - {2185221600 10800 1 EEST} - {2203365600 7200 0 EET} - {2216671200 10800 1 EEST} - {2234815200 7200 0 EET} - {2248120800 10800 1 EEST} - {2266264800 7200 0 EET} - {2279570400 10800 1 EEST} - {2298319200 7200 0 EET} - {2311020000 10800 1 EEST} - {2329768800 7200 0 EET} - {2343074400 10800 1 EEST} - {2361218400 7200 0 EET} - {2374524000 10800 1 EEST} - {2392668000 7200 0 EET} - {2405973600 10800 1 EEST} - {2424117600 7200 0 EET} - {2437423200 10800 1 EEST} - {2455567200 7200 0 EET} - {2468872800 10800 1 EEST} - {2487621600 7200 0 EET} - {2500322400 10800 1 EEST} - {2519071200 7200 0 EET} - {2532376800 10800 1 EEST} - {2550520800 7200 0 EET} - {2563826400 10800 1 EEST} - {2581970400 7200 0 EET} - {2595276000 10800 1 EEST} - {2613420000 7200 0 EET} - {2626725600 10800 1 EEST} - {2645474400 7200 0 EET} - {2658175200 10800 1 EEST} - {2676924000 7200 0 EET} - {2689624800 10800 1 EEST} - {2708373600 7200 0 EET} - {2721679200 10800 1 EEST} - {2739823200 7200 0 EET} - {2753128800 10800 1 EEST} - {2771272800 7200 0 EET} - {2784578400 10800 1 EEST} - {2802722400 7200 0 EET} - {2816028000 10800 1 EEST} - {2834776800 7200 0 EET} - {2847477600 10800 1 EEST} - {2866226400 7200 0 EET} - {2879532000 10800 1 EEST} - {2897676000 7200 0 EET} - {2910981600 10800 1 EEST} - {2929125600 7200 0 EET} - {2942431200 10800 1 EEST} - {2960575200 7200 0 EET} - {2973880800 10800 1 EEST} - {2992629600 7200 0 EET} - {3005330400 10800 1 EEST} - {3024079200 7200 0 EET} - {3036780000 10800 1 EEST} - {3055528800 7200 0 EET} - {3068834400 10800 1 EEST} - {3086978400 7200 0 EET} - {3100284000 10800 1 EEST} - {3118428000 7200 0 EET} - {3131733600 10800 1 EEST} - {3149877600 7200 0 EET} - {3163183200 10800 1 EEST} - {3181932000 7200 0 EET} - {3194632800 10800 1 EEST} - {3213381600 7200 0 EET} - {3226687200 10800 1 EEST} - {3244831200 7200 0 EET} - {3258136800 10800 1 EEST} - {3276280800 7200 0 EET} - {3289586400 10800 1 EEST} - {3307730400 7200 0 EET} - {3321036000 10800 1 EEST} - {3339180000 7200 0 EET} - {3352485600 10800 1 EEST} - {3371234400 7200 0 EET} - {3383935200 10800 1 EEST} - {3402684000 7200 0 EET} - {3415989600 10800 1 EEST} - {3434133600 7200 0 EET} - {3447439200 10800 1 EEST} - {3465583200 7200 0 EET} - {3478888800 10800 1 EEST} - {3497032800 7200 0 EET} - {3510338400 10800 1 EEST} - {3529087200 7200 0 EET} - {3541788000 10800 1 EEST} - {3560536800 7200 0 EET} - {3573237600 10800 1 EEST} - {3591986400 7200 0 EET} - {3605292000 10800 1 EEST} - {3623436000 7200 0 EET} - {3636741600 10800 1 EEST} - {3654885600 7200 0 EET} - {3668191200 10800 1 EEST} - {3686335200 7200 0 EET} - {3699640800 10800 1 EEST} - {3718389600 7200 0 EET} - {3731090400 10800 1 EEST} - {3749839200 7200 0 EET} - {3763144800 10800 1 EEST} - {3781288800 7200 0 EET} - {3794594400 10800 1 EEST} - {3812738400 7200 0 EET} - {3826044000 10800 1 EEST} - {3844188000 7200 0 EET} - {3857493600 10800 1 EEST} - {3876242400 7200 0 EET} - {3888943200 10800 1 EEST} - {3907692000 7200 0 EET} - {3920392800 10800 1 EEST} - {3939141600 7200 0 EET} - {3952447200 10800 1 EEST} - {3970591200 7200 0 EET} - {3983896800 10800 1 EEST} - {4002040800 7200 0 EET} - {4015346400 10800 1 EEST} - {4033490400 7200 0 EET} - {4046796000 10800 1 EEST} - {4065544800 7200 0 EET} - {4078245600 10800 1 EEST} - {4096994400 7200 0 EET} + {1351202400 10800 0 AST} } diff --git a/library/tzdata/Asia/Dili b/library/tzdata/Asia/Dili index 36910fd..f783557 100644 --- a/library/tzdata/Asia/Dili +++ b/library/tzdata/Asia/Dili @@ -5,6 +5,6 @@ set TZData(:Asia/Dili) { {-1830414140 28800 0 TLT} {-879152400 32400 0 JST} {-766054800 32400 0 TLT} - {199897200 28800 0 CIT} + {199897200 28800 0 WITA} {969120000 32400 0 TLT} } diff --git a/library/tzdata/Asia/Gaza b/library/tzdata/Asia/Gaza index a0636e2..7d62a96 100644 --- a/library/tzdata/Asia/Gaza +++ b/library/tzdata/Asia/Gaza @@ -102,177 +102,177 @@ set TZData(:Asia/Gaza) { {1333058400 10800 1 EEST} {1348178400 7200 0 EET} {1364508000 10800 1 EEST} - {1380232800 7200 0 EET} + {1380229200 7200 0 EET} {1395957600 10800 1 EEST} - {1411682400 7200 0 EET} + {1411678800 7200 0 EET} {1427407200 10800 1 EEST} - {1443132000 7200 0 EET} + {1443128400 7200 0 EET} {1459461600 10800 1 EEST} - {1474581600 7200 0 EET} + {1474578000 7200 0 EET} {1490911200 10800 1 EEST} - {1506031200 7200 0 EET} + {1506027600 7200 0 EET} {1522360800 10800 1 EEST} - {1537480800 7200 0 EET} + {1537477200 7200 0 EET} {1553810400 10800 1 EEST} - {1569535200 7200 0 EET} + {1569531600 7200 0 EET} {1585260000 10800 1 EEST} - {1600984800 7200 0 EET} + {1600981200 7200 0 EET} {1616709600 10800 1 EEST} - {1632434400 7200 0 EET} + {1632430800 7200 0 EET} {1648764000 10800 1 EEST} - {1663884000 7200 0 EET} + {1663880400 7200 0 EET} {1680213600 10800 1 EEST} - {1695333600 7200 0 EET} + {1695330000 7200 0 EET} {1711663200 10800 1 EEST} - {1727388000 7200 0 EET} + {1727384400 7200 0 EET} {1743112800 10800 1 EEST} - {1758837600 7200 0 EET} + {1758834000 7200 0 EET} {1774562400 10800 1 EEST} - {1790287200 7200 0 EET} + {1790283600 7200 0 EET} {1806012000 10800 1 EEST} - {1821736800 7200 0 EET} + {1821733200 7200 0 EET} {1838066400 10800 1 EEST} - {1853186400 7200 0 EET} + {1853182800 7200 0 EET} {1869516000 10800 1 EEST} - {1884636000 7200 0 EET} + {1884632400 7200 0 EET} {1900965600 10800 1 EEST} - {1916690400 7200 0 EET} + {1916686800 7200 0 EET} {1932415200 10800 1 EEST} - {1948140000 7200 0 EET} + {1948136400 7200 0 EET} {1963864800 10800 1 EEST} - {1979589600 7200 0 EET} + {1979586000 7200 0 EET} {1995919200 10800 1 EEST} - {2011039200 7200 0 EET} + {2011035600 7200 0 EET} {2027368800 10800 1 EEST} - {2042488800 7200 0 EET} + {2042485200 7200 0 EET} {2058818400 10800 1 EEST} - {2073938400 7200 0 EET} + {2073934800 7200 0 EET} {2090268000 10800 1 EEST} - {2105992800 7200 0 EET} + {2105989200 7200 0 EET} {2121717600 10800 1 EEST} - {2137442400 7200 0 EET} + {2137438800 7200 0 EET} {2153167200 10800 1 EEST} - {2168892000 7200 0 EET} + {2168888400 7200 0 EET} {2185221600 10800 1 EEST} - {2200341600 7200 0 EET} + {2200338000 7200 0 EET} {2216671200 10800 1 EEST} - {2231791200 7200 0 EET} + {2231787600 7200 0 EET} {2248120800 10800 1 EEST} - {2263845600 7200 0 EET} + {2263842000 7200 0 EET} {2279570400 10800 1 EEST} - {2295295200 7200 0 EET} + {2295291600 7200 0 EET} {2311020000 10800 1 EEST} - {2326744800 7200 0 EET} + {2326741200 7200 0 EET} {2343074400 10800 1 EEST} - {2358194400 7200 0 EET} + {2358190800 7200 0 EET} {2374524000 10800 1 EEST} - {2389644000 7200 0 EET} + {2389640400 7200 0 EET} {2405973600 10800 1 EEST} - {2421093600 7200 0 EET} + {2421090000 7200 0 EET} {2437423200 10800 1 EEST} - {2453148000 7200 0 EET} + {2453144400 7200 0 EET} {2468872800 10800 1 EEST} - {2484597600 7200 0 EET} + {2484594000 7200 0 EET} {2500322400 10800 1 EEST} - {2516047200 7200 0 EET} + {2516043600 7200 0 EET} {2532376800 10800 1 EEST} - {2547496800 7200 0 EET} + {2547493200 7200 0 EET} {2563826400 10800 1 EEST} - {2578946400 7200 0 EET} + {2578942800 7200 0 EET} {2595276000 10800 1 EEST} - {2611000800 7200 0 EET} + {2610997200 7200 0 EET} {2626725600 10800 1 EEST} - {2642450400 7200 0 EET} + {2642446800 7200 0 EET} {2658175200 10800 1 EEST} - {2673900000 7200 0 EET} + {2673896400 7200 0 EET} {2689624800 10800 1 EEST} - {2705349600 7200 0 EET} + {2705346000 7200 0 EET} {2721679200 10800 1 EEST} - {2736799200 7200 0 EET} + {2736795600 7200 0 EET} {2753128800 10800 1 EEST} - {2768248800 7200 0 EET} + {2768245200 7200 0 EET} {2784578400 10800 1 EEST} - {2800303200 7200 0 EET} + {2800299600 7200 0 EET} {2816028000 10800 1 EEST} - {2831752800 7200 0 EET} + {2831749200 7200 0 EET} {2847477600 10800 1 EEST} - {2863202400 7200 0 EET} + {2863198800 7200 0 EET} {2879532000 10800 1 EEST} - {2894652000 7200 0 EET} + {2894648400 7200 0 EET} {2910981600 10800 1 EEST} - {2926101600 7200 0 EET} + {2926098000 7200 0 EET} {2942431200 10800 1 EEST} - {2957551200 7200 0 EET} + {2957547600 7200 0 EET} {2973880800 10800 1 EEST} - {2989605600 7200 0 EET} + {2989602000 7200 0 EET} {3005330400 10800 1 EEST} - {3021055200 7200 0 EET} + {3021051600 7200 0 EET} {3036780000 10800 1 EEST} - {3052504800 7200 0 EET} + {3052501200 7200 0 EET} {3068834400 10800 1 EEST} - {3083954400 7200 0 EET} + {3083950800 7200 0 EET} {3100284000 10800 1 EEST} - {3115404000 7200 0 EET} + {3115400400 7200 0 EET} {3131733600 10800 1 EEST} - {3147458400 7200 0 EET} + {3147454800 7200 0 EET} {3163183200 10800 1 EEST} - {3178908000 7200 0 EET} + {3178904400 7200 0 EET} {3194632800 10800 1 EEST} - {3210357600 7200 0 EET} + {3210354000 7200 0 EET} {3226687200 10800 1 EEST} - {3241807200 7200 0 EET} + {3241803600 7200 0 EET} {3258136800 10800 1 EEST} - {3273256800 7200 0 EET} + {3273253200 7200 0 EET} {3289586400 10800 1 EEST} - {3304706400 7200 0 EET} + {3304702800 7200 0 EET} {3321036000 10800 1 EEST} - {3336760800 7200 0 EET} + {3336757200 7200 0 EET} {3352485600 10800 1 EEST} - {3368210400 7200 0 EET} + {3368206800 7200 0 EET} {3383935200 10800 1 EEST} - {3399660000 7200 0 EET} + {3399656400 7200 0 EET} {3415989600 10800 1 EEST} - {3431109600 7200 0 EET} + {3431106000 7200 0 EET} {3447439200 10800 1 EEST} - {3462559200 7200 0 EET} + {3462555600 7200 0 EET} {3478888800 10800 1 EEST} - {3494613600 7200 0 EET} + {3494610000 7200 0 EET} {3510338400 10800 1 EEST} - {3526063200 7200 0 EET} + {3526059600 7200 0 EET} {3541788000 10800 1 EEST} - {3557512800 7200 0 EET} + {3557509200 7200 0 EET} {3573237600 10800 1 EEST} - {3588962400 7200 0 EET} + {3588958800 7200 0 EET} {3605292000 10800 1 EEST} - {3620412000 7200 0 EET} + {3620408400 7200 0 EET} {3636741600 10800 1 EEST} - {3651861600 7200 0 EET} + {3651858000 7200 0 EET} {3668191200 10800 1 EEST} - {3683916000 7200 0 EET} + {3683912400 7200 0 EET} {3699640800 10800 1 EEST} - {3715365600 7200 0 EET} + {3715362000 7200 0 EET} {3731090400 10800 1 EEST} - {3746815200 7200 0 EET} + {3746811600 7200 0 EET} {3763144800 10800 1 EEST} - {3778264800 7200 0 EET} + {3778261200 7200 0 EET} {3794594400 10800 1 EEST} - {3809714400 7200 0 EET} + {3809710800 7200 0 EET} {3826044000 10800 1 EEST} - {3841164000 7200 0 EET} + {3841160400 7200 0 EET} {3857493600 10800 1 EEST} - {3873218400 7200 0 EET} + {3873214800 7200 0 EET} {3888943200 10800 1 EEST} - {3904668000 7200 0 EET} + {3904664400 7200 0 EET} {3920392800 10800 1 EEST} - {3936117600 7200 0 EET} + {3936114000 7200 0 EET} {3952447200 10800 1 EEST} - {3967567200 7200 0 EET} + {3967563600 7200 0 EET} {3983896800 10800 1 EEST} - {3999016800 7200 0 EET} + {3999013200 7200 0 EET} {4015346400 10800 1 EEST} - {4031071200 7200 0 EET} + {4031067600 7200 0 EET} {4046796000 10800 1 EEST} - {4062520800 7200 0 EET} + {4062517200 7200 0 EET} {4078245600 10800 1 EEST} - {4093970400 7200 0 EET} + {4093966800 7200 0 EET} } diff --git a/library/tzdata/Asia/Hebron b/library/tzdata/Asia/Hebron index a8a9019..1333d5a 100644 --- a/library/tzdata/Asia/Hebron +++ b/library/tzdata/Asia/Hebron @@ -101,177 +101,177 @@ set TZData(:Asia/Hebron) { {1333058400 10800 1 EEST} {1348178400 7200 0 EET} {1364508000 10800 1 EEST} - {1380232800 7200 0 EET} + {1380229200 7200 0 EET} {1395957600 10800 1 EEST} - {1411682400 7200 0 EET} + {1411678800 7200 0 EET} {1427407200 10800 1 EEST} - {1443132000 7200 0 EET} + {1443128400 7200 0 EET} {1459461600 10800 1 EEST} - {1474581600 7200 0 EET} + {1474578000 7200 0 EET} {1490911200 10800 1 EEST} - {1506031200 7200 0 EET} + {1506027600 7200 0 EET} {1522360800 10800 1 EEST} - {1537480800 7200 0 EET} + {1537477200 7200 0 EET} {1553810400 10800 1 EEST} - {1569535200 7200 0 EET} + {1569531600 7200 0 EET} {1585260000 10800 1 EEST} - {1600984800 7200 0 EET} + {1600981200 7200 0 EET} {1616709600 10800 1 EEST} - {1632434400 7200 0 EET} + {1632430800 7200 0 EET} {1648764000 10800 1 EEST} - {1663884000 7200 0 EET} + {1663880400 7200 0 EET} {1680213600 10800 1 EEST} - {1695333600 7200 0 EET} + {1695330000 7200 0 EET} {1711663200 10800 1 EEST} - {1727388000 7200 0 EET} + {1727384400 7200 0 EET} {1743112800 10800 1 EEST} - {1758837600 7200 0 EET} + {1758834000 7200 0 EET} {1774562400 10800 1 EEST} - {1790287200 7200 0 EET} + {1790283600 7200 0 EET} {1806012000 10800 1 EEST} - {1821736800 7200 0 EET} + {1821733200 7200 0 EET} {1838066400 10800 1 EEST} - {1853186400 7200 0 EET} + {1853182800 7200 0 EET} {1869516000 10800 1 EEST} - {1884636000 7200 0 EET} + {1884632400 7200 0 EET} {1900965600 10800 1 EEST} - {1916690400 7200 0 EET} + {1916686800 7200 0 EET} {1932415200 10800 1 EEST} - {1948140000 7200 0 EET} + {1948136400 7200 0 EET} {1963864800 10800 1 EEST} - {1979589600 7200 0 EET} + {1979586000 7200 0 EET} {1995919200 10800 1 EEST} - {2011039200 7200 0 EET} + {2011035600 7200 0 EET} {2027368800 10800 1 EEST} - {2042488800 7200 0 EET} + {2042485200 7200 0 EET} {2058818400 10800 1 EEST} - {2073938400 7200 0 EET} + {2073934800 7200 0 EET} {2090268000 10800 1 EEST} - {2105992800 7200 0 EET} + {2105989200 7200 0 EET} {2121717600 10800 1 EEST} - {2137442400 7200 0 EET} + {2137438800 7200 0 EET} {2153167200 10800 1 EEST} - {2168892000 7200 0 EET} + {2168888400 7200 0 EET} {2185221600 10800 1 EEST} - {2200341600 7200 0 EET} + {2200338000 7200 0 EET} {2216671200 10800 1 EEST} - {2231791200 7200 0 EET} + {2231787600 7200 0 EET} {2248120800 10800 1 EEST} - {2263845600 7200 0 EET} + {2263842000 7200 0 EET} {2279570400 10800 1 EEST} - {2295295200 7200 0 EET} + {2295291600 7200 0 EET} {2311020000 10800 1 EEST} - {2326744800 7200 0 EET} + {2326741200 7200 0 EET} {2343074400 10800 1 EEST} - {2358194400 7200 0 EET} + {2358190800 7200 0 EET} {2374524000 10800 1 EEST} - {2389644000 7200 0 EET} + {2389640400 7200 0 EET} {2405973600 10800 1 EEST} - {2421093600 7200 0 EET} + {2421090000 7200 0 EET} {2437423200 10800 1 EEST} - {2453148000 7200 0 EET} + {2453144400 7200 0 EET} {2468872800 10800 1 EEST} - {2484597600 7200 0 EET} + {2484594000 7200 0 EET} {2500322400 10800 1 EEST} - {2516047200 7200 0 EET} + {2516043600 7200 0 EET} {2532376800 10800 1 EEST} - {2547496800 7200 0 EET} + {2547493200 7200 0 EET} {2563826400 10800 1 EEST} - {2578946400 7200 0 EET} + {2578942800 7200 0 EET} {2595276000 10800 1 EEST} - {2611000800 7200 0 EET} + {2610997200 7200 0 EET} {2626725600 10800 1 EEST} - {2642450400 7200 0 EET} + {2642446800 7200 0 EET} {2658175200 10800 1 EEST} - {2673900000 7200 0 EET} + {2673896400 7200 0 EET} {2689624800 10800 1 EEST} - {2705349600 7200 0 EET} + {2705346000 7200 0 EET} {2721679200 10800 1 EEST} - {2736799200 7200 0 EET} + {2736795600 7200 0 EET} {2753128800 10800 1 EEST} - {2768248800 7200 0 EET} + {2768245200 7200 0 EET} {2784578400 10800 1 EEST} - {2800303200 7200 0 EET} + {2800299600 7200 0 EET} {2816028000 10800 1 EEST} - {2831752800 7200 0 EET} + {2831749200 7200 0 EET} {2847477600 10800 1 EEST} - {2863202400 7200 0 EET} + {2863198800 7200 0 EET} {2879532000 10800 1 EEST} - {2894652000 7200 0 EET} + {2894648400 7200 0 EET} {2910981600 10800 1 EEST} - {2926101600 7200 0 EET} + {2926098000 7200 0 EET} {2942431200 10800 1 EEST} - {2957551200 7200 0 EET} + {2957547600 7200 0 EET} {2973880800 10800 1 EEST} - {2989605600 7200 0 EET} + {2989602000 7200 0 EET} {3005330400 10800 1 EEST} - {3021055200 7200 0 EET} + {3021051600 7200 0 EET} {3036780000 10800 1 EEST} - {3052504800 7200 0 EET} + {3052501200 7200 0 EET} {3068834400 10800 1 EEST} - {3083954400 7200 0 EET} + {3083950800 7200 0 EET} {3100284000 10800 1 EEST} - {3115404000 7200 0 EET} + {3115400400 7200 0 EET} {3131733600 10800 1 EEST} - {3147458400 7200 0 EET} + {3147454800 7200 0 EET} {3163183200 10800 1 EEST} - {3178908000 7200 0 EET} + {3178904400 7200 0 EET} {3194632800 10800 1 EEST} - {3210357600 7200 0 EET} + {3210354000 7200 0 EET} {3226687200 10800 1 EEST} - {3241807200 7200 0 EET} + {3241803600 7200 0 EET} {3258136800 10800 1 EEST} - {3273256800 7200 0 EET} + {3273253200 7200 0 EET} {3289586400 10800 1 EEST} - {3304706400 7200 0 EET} + {3304702800 7200 0 EET} {3321036000 10800 1 EEST} - {3336760800 7200 0 EET} + {3336757200 7200 0 EET} {3352485600 10800 1 EEST} - {3368210400 7200 0 EET} + {3368206800 7200 0 EET} {3383935200 10800 1 EEST} - {3399660000 7200 0 EET} + {3399656400 7200 0 EET} {3415989600 10800 1 EEST} - {3431109600 7200 0 EET} + {3431106000 7200 0 EET} {3447439200 10800 1 EEST} - {3462559200 7200 0 EET} + {3462555600 7200 0 EET} {3478888800 10800 1 EEST} - {3494613600 7200 0 EET} + {3494610000 7200 0 EET} {3510338400 10800 1 EEST} - {3526063200 7200 0 EET} + {3526059600 7200 0 EET} {3541788000 10800 1 EEST} - {3557512800 7200 0 EET} + {3557509200 7200 0 EET} {3573237600 10800 1 EEST} - {3588962400 7200 0 EET} + {3588958800 7200 0 EET} {3605292000 10800 1 EEST} - {3620412000 7200 0 EET} + {3620408400 7200 0 EET} {3636741600 10800 1 EEST} - {3651861600 7200 0 EET} + {3651858000 7200 0 EET} {3668191200 10800 1 EEST} - {3683916000 7200 0 EET} + {3683912400 7200 0 EET} {3699640800 10800 1 EEST} - {3715365600 7200 0 EET} + {3715362000 7200 0 EET} {3731090400 10800 1 EEST} - {3746815200 7200 0 EET} + {3746811600 7200 0 EET} {3763144800 10800 1 EEST} - {3778264800 7200 0 EET} + {3778261200 7200 0 EET} {3794594400 10800 1 EEST} - {3809714400 7200 0 EET} + {3809710800 7200 0 EET} {3826044000 10800 1 EEST} - {3841164000 7200 0 EET} + {3841160400 7200 0 EET} {3857493600 10800 1 EEST} - {3873218400 7200 0 EET} + {3873214800 7200 0 EET} {3888943200 10800 1 EEST} - {3904668000 7200 0 EET} + {3904664400 7200 0 EET} {3920392800 10800 1 EEST} - {3936117600 7200 0 EET} + {3936114000 7200 0 EET} {3952447200 10800 1 EEST} - {3967567200 7200 0 EET} + {3967563600 7200 0 EET} {3983896800 10800 1 EEST} - {3999016800 7200 0 EET} + {3999013200 7200 0 EET} {4015346400 10800 1 EEST} - {4031071200 7200 0 EET} + {4031067600 7200 0 EET} {4046796000 10800 1 EEST} - {4062520800 7200 0 EET} + {4062517200 7200 0 EET} {4078245600 10800 1 EEST} - {4093970400 7200 0 EET} + {4093966800 7200 0 EET} } diff --git a/library/tzdata/Asia/Jakarta b/library/tzdata/Asia/Jakarta index 27033e8..75cd659 100644 --- a/library/tzdata/Asia/Jakarta +++ b/library/tzdata/Asia/Jakarta @@ -2,12 +2,12 @@ set TZData(:Asia/Jakarta) { {-9223372036854775808 25632 0 LMT} - {-3231299232 25632 0 JMT} + {-3231299232 25632 0 BMT} {-1451719200 26400 0 JAVT} - {-1172906400 27000 0 WIT} + {-1172906400 27000 0 WIB} {-876641400 32400 0 JST} - {-766054800 27000 0 WIT} - {-683883000 28800 0 WIT} - {-620812800 27000 0 WIT} - {-189415800 25200 0 WIT} + {-766054800 27000 0 WIB} + {-683883000 28800 0 WIB} + {-620812800 27000 0 WIB} + {-189415800 25200 0 WIB} } diff --git a/library/tzdata/Asia/Jayapura b/library/tzdata/Asia/Jayapura index 893da8b..a71228f 100644 --- a/library/tzdata/Asia/Jayapura +++ b/library/tzdata/Asia/Jayapura @@ -2,7 +2,7 @@ set TZData(:Asia/Jayapura) { {-9223372036854775808 33768 0 LMT} - {-1172913768 32400 0 EIT} + {-1172913768 32400 0 WIT} {-799491600 34200 0 CST} - {-189423000 32400 0 EIT} + {-189423000 32400 0 WIT} } diff --git a/library/tzdata/Asia/Makassar b/library/tzdata/Asia/Makassar index aa604b4..be947f3 100644 --- a/library/tzdata/Asia/Makassar +++ b/library/tzdata/Asia/Makassar @@ -3,7 +3,7 @@ set TZData(:Asia/Makassar) { {-9223372036854775808 28656 0 LMT} {-1577951856 28656 0 MMT} - {-1172908656 28800 0 CIT} + {-1172908656 28800 0 WITA} {-880272000 32400 0 JST} - {-766054800 28800 0 CIT} + {-766054800 28800 0 WITA} } diff --git a/library/tzdata/Asia/Pontianak b/library/tzdata/Asia/Pontianak index f3567dd..728b552 100644 --- a/library/tzdata/Asia/Pontianak +++ b/library/tzdata/Asia/Pontianak @@ -3,11 +3,11 @@ set TZData(:Asia/Pontianak) { {-9223372036854775808 26240 0 LMT} {-1946186240 26240 0 PMT} - {-1172906240 27000 0 WIT} + {-1172906240 27000 0 WIB} {-881220600 32400 0 JST} - {-766054800 27000 0 WIT} - {-683883000 28800 0 WIT} - {-620812800 27000 0 WIT} - {-189415800 28800 0 CIT} - {567964800 25200 0 WIT} + {-766054800 27000 0 WIB} + {-683883000 28800 0 WIB} + {-620812800 27000 0 WIB} + {-189415800 28800 0 WITA} + {567964800 25200 0 WIB} } diff --git a/library/tzdata/Europe/Vaduz b/library/tzdata/Europe/Vaduz index 3118331..095e018 100644 --- a/library/tzdata/Europe/Vaduz +++ b/library/tzdata/Europe/Vaduz @@ -1,245 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Vaduz) { - {-9223372036854775808 2284 0 LMT} - {-2385247084 3600 0 CET} - {347151600 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} - {449024400 7200 1 CEST} - {465354000 3600 0 CET} - {481078800 7200 1 CEST} - {496803600 3600 0 CET} - {512528400 7200 1 CEST} - {528253200 3600 0 CET} - {543978000 7200 1 CEST} - {559702800 3600 0 CET} - {575427600 7200 1 CEST} - {591152400 3600 0 CET} - {606877200 7200 1 CEST} - {622602000 3600 0 CET} - {638326800 7200 1 CEST} - {654656400 3600 0 CET} - {670381200 7200 1 CEST} - {686106000 3600 0 CET} - {701830800 7200 1 CEST} - {717555600 3600 0 CET} - {733280400 7200 1 CEST} - {749005200 3600 0 CET} - {764730000 7200 1 CEST} - {780454800 3600 0 CET} - {796179600 7200 1 CEST} - {811904400 3600 0 CET} - {828234000 7200 1 CEST} - {846378000 3600 0 CET} - {859683600 7200 1 CEST} - {877827600 3600 0 CET} - {891133200 7200 1 CEST} - {909277200 3600 0 CET} - {922582800 7200 1 CEST} - {941331600 3600 0 CET} - {954032400 7200 1 CEST} - {972781200 3600 0 CET} - {985482000 7200 1 CEST} - {1004230800 3600 0 CET} - {1017536400 7200 1 CEST} - {1035680400 3600 0 CET} - {1048986000 7200 1 CEST} - {1067130000 3600 0 CET} - {1080435600 7200 1 CEST} - {1099184400 3600 0 CET} - {1111885200 7200 1 CEST} - {1130634000 3600 0 CET} - {1143334800 7200 1 CEST} - {1162083600 3600 0 CET} - {1174784400 7200 1 CEST} - {1193533200 3600 0 CET} - {1206838800 7200 1 CEST} - {1224982800 3600 0 CET} - {1238288400 7200 1 CEST} - {1256432400 3600 0 CET} - {1269738000 7200 1 CEST} - {1288486800 3600 0 CET} - {1301187600 7200 1 CEST} - {1319936400 3600 0 CET} - {1332637200 7200 1 CEST} - {1351386000 3600 0 CET} - {1364691600 7200 1 CEST} - {1382835600 3600 0 CET} - {1396141200 7200 1 CEST} - {1414285200 3600 0 CET} - {1427590800 7200 1 CEST} - {1445734800 3600 0 CET} - {1459040400 7200 1 CEST} - {1477789200 3600 0 CET} - {1490490000 7200 1 CEST} - {1509238800 3600 0 CET} - {1521939600 7200 1 CEST} - {1540688400 3600 0 CET} - {1553994000 7200 1 CEST} - {1572138000 3600 0 CET} - {1585443600 7200 1 CEST} - {1603587600 3600 0 CET} - {1616893200 7200 1 CEST} - {1635642000 3600 0 CET} - {1648342800 7200 1 CEST} - {1667091600 3600 0 CET} - {1679792400 7200 1 CEST} - {1698541200 3600 0 CET} - {1711846800 7200 1 CEST} - {1729990800 3600 0 CET} - {1743296400 7200 1 CEST} - {1761440400 3600 0 CET} - {1774746000 7200 1 CEST} - {1792890000 3600 0 CET} - {1806195600 7200 1 CEST} - {1824944400 3600 0 CET} - {1837645200 7200 1 CEST} - {1856394000 3600 0 CET} - {1869094800 7200 1 CEST} - {1887843600 3600 0 CET} - {1901149200 7200 1 CEST} - {1919293200 3600 0 CET} - {1932598800 7200 1 CEST} - {1950742800 3600 0 CET} - {1964048400 7200 1 CEST} - {1982797200 3600 0 CET} - {1995498000 7200 1 CEST} - {2014246800 3600 0 CET} - {2026947600 7200 1 CEST} - {2045696400 3600 0 CET} - {2058397200 7200 1 CEST} - {2077146000 3600 0 CET} - {2090451600 7200 1 CEST} - {2108595600 3600 0 CET} - {2121901200 7200 1 CEST} - {2140045200 3600 0 CET} - {2153350800 7200 1 CEST} - {2172099600 3600 0 CET} - {2184800400 7200 1 CEST} - {2203549200 3600 0 CET} - {2216250000 7200 1 CEST} - {2234998800 3600 0 CET} - {2248304400 7200 1 CEST} - {2266448400 3600 0 CET} - {2279754000 7200 1 CEST} - {2297898000 3600 0 CET} - {2311203600 7200 1 CEST} - {2329347600 3600 0 CET} - {2342653200 7200 1 CEST} - {2361402000 3600 0 CET} - {2374102800 7200 1 CEST} - {2392851600 3600 0 CET} - {2405552400 7200 1 CEST} - {2424301200 3600 0 CET} - {2437606800 7200 1 CEST} - {2455750800 3600 0 CET} - {2469056400 7200 1 CEST} - {2487200400 3600 0 CET} - {2500506000 7200 1 CEST} - {2519254800 3600 0 CET} - {2531955600 7200 1 CEST} - {2550704400 3600 0 CET} - {2563405200 7200 1 CEST} - {2582154000 3600 0 CET} - {2595459600 7200 1 CEST} - {2613603600 3600 0 CET} - {2626909200 7200 1 CEST} - {2645053200 3600 0 CET} - {2658358800 7200 1 CEST} - {2676502800 3600 0 CET} - {2689808400 7200 1 CEST} - {2708557200 3600 0 CET} - {2721258000 7200 1 CEST} - {2740006800 3600 0 CET} - {2752707600 7200 1 CEST} - {2771456400 3600 0 CET} - {2784762000 7200 1 CEST} - {2802906000 3600 0 CET} - {2816211600 7200 1 CEST} - {2834355600 3600 0 CET} - {2847661200 7200 1 CEST} - {2866410000 3600 0 CET} - {2879110800 7200 1 CEST} - {2897859600 3600 0 CET} - {2910560400 7200 1 CEST} - {2929309200 3600 0 CET} - {2942010000 7200 1 CEST} - {2960758800 3600 0 CET} - {2974064400 7200 1 CEST} - {2992208400 3600 0 CET} - {3005514000 7200 1 CEST} - {3023658000 3600 0 CET} - {3036963600 7200 1 CEST} - {3055712400 3600 0 CET} - {3068413200 7200 1 CEST} - {3087162000 3600 0 CET} - {3099862800 7200 1 CEST} - {3118611600 3600 0 CET} - {3131917200 7200 1 CEST} - {3150061200 3600 0 CET} - {3163366800 7200 1 CEST} - {3181510800 3600 0 CET} - {3194816400 7200 1 CEST} - {3212960400 3600 0 CET} - {3226266000 7200 1 CEST} - {3245014800 3600 0 CET} - {3257715600 7200 1 CEST} - {3276464400 3600 0 CET} - {3289165200 7200 1 CEST} - {3307914000 3600 0 CET} - {3321219600 7200 1 CEST} - {3339363600 3600 0 CET} - {3352669200 7200 1 CEST} - {3370813200 3600 0 CET} - {3384118800 7200 1 CEST} - {3402867600 3600 0 CET} - {3415568400 7200 1 CEST} - {3434317200 3600 0 CET} - {3447018000 7200 1 CEST} - {3465766800 3600 0 CET} - {3479072400 7200 1 CEST} - {3497216400 3600 0 CET} - {3510522000 7200 1 CEST} - {3528666000 3600 0 CET} - {3541971600 7200 1 CEST} - {3560115600 3600 0 CET} - {3573421200 7200 1 CEST} - {3592170000 3600 0 CET} - {3604870800 7200 1 CEST} - {3623619600 3600 0 CET} - {3636320400 7200 1 CEST} - {3655069200 3600 0 CET} - {3668374800 7200 1 CEST} - {3686518800 3600 0 CET} - {3699824400 7200 1 CEST} - {3717968400 3600 0 CET} - {3731274000 7200 1 CEST} - {3750022800 3600 0 CET} - {3762723600 7200 1 CEST} - {3781472400 3600 0 CET} - {3794173200 7200 1 CEST} - {3812922000 3600 0 CET} - {3825622800 7200 1 CEST} - {3844371600 3600 0 CET} - {3857677200 7200 1 CEST} - {3875821200 3600 0 CET} - {3889126800 7200 1 CEST} - {3907270800 3600 0 CET} - {3920576400 7200 1 CEST} - {3939325200 3600 0 CET} - {3952026000 7200 1 CEST} - {3970774800 3600 0 CET} - {3983475600 7200 1 CEST} - {4002224400 3600 0 CET} - {4015530000 7200 1 CEST} - {4033674000 3600 0 CET} - {4046979600 7200 1 CEST} - {4065123600 3600 0 CET} - {4078429200 7200 1 CEST} - {4096573200 3600 0 CET} +if {![info exists TZData(Europe/Zurich)]} { + LoadTimeZoneFile Europe/Zurich } +set TZData(:Europe/Vaduz) $TZData(:Europe/Zurich) diff --git a/library/tzdata/Europe/Zurich b/library/tzdata/Europe/Zurich index 33831c3..87a20db 100644 --- a/library/tzdata/Europe/Zurich +++ b/library/tzdata/Europe/Zurich @@ -2,8 +2,8 @@ set TZData(:Europe/Zurich) { {-9223372036854775808 2048 0 LMT} - {-3827954048 1784 0 BMT} - {-2385246584 3600 0 CET} + {-3675198848 1786 0 BMT} + {-2385246586 3600 0 CET} {-904435200 7200 1 CEST} {-891129600 3600 0 CET} {-872985600 7200 1 CEST} diff --git a/library/tzdata/Pacific/Fiji b/library/tzdata/Pacific/Fiji index bfcaa03..454ee87 100644 --- a/library/tzdata/Pacific/Fiji +++ b/library/tzdata/Pacific/Fiji @@ -15,11 +15,11 @@ set TZData(:Pacific/Fiji) { {1327154400 43200 0 FJT} {1350741600 46800 1 FJST} {1358604000 43200 0 FJT} - {1382191200 46800 1 FJST} + {1382796000 46800 1 FJST} {1390053600 43200 0 FJT} - {1413640800 46800 1 FJST} + {1414245600 46800 1 FJST} {1421503200 43200 0 FJT} - {1445090400 46800 1 FJST} + {1445695200 46800 1 FJST} {1453557600 43200 0 FJT} {1477144800 46800 1 FJST} {1485007200 43200 0 FJT} @@ -27,9 +27,9 @@ set TZData(:Pacific/Fiji) { {1516456800 43200 0 FJT} {1540044000 46800 1 FJST} {1547906400 43200 0 FJT} - {1571493600 46800 1 FJST} + {1572098400 46800 1 FJST} {1579356000 43200 0 FJT} - {1602943200 46800 1 FJST} + {1603548000 46800 1 FJST} {1611410400 43200 0 FJT} {1634997600 46800 1 FJST} {1642860000 43200 0 FJT} @@ -37,11 +37,11 @@ set TZData(:Pacific/Fiji) { {1674309600 43200 0 FJT} {1697896800 46800 1 FJST} {1705759200 43200 0 FJT} - {1729346400 46800 1 FJST} + {1729951200 46800 1 FJST} {1737208800 43200 0 FJT} - {1760796000 46800 1 FJST} + {1761400800 46800 1 FJST} {1768658400 43200 0 FJT} - {1792245600 46800 1 FJST} + {1792850400 46800 1 FJST} {1800712800 43200 0 FJT} {1824300000 46800 1 FJST} {1832162400 43200 0 FJT} @@ -49,9 +49,9 @@ set TZData(:Pacific/Fiji) { {1863612000 43200 0 FJT} {1887199200 46800 1 FJST} {1895061600 43200 0 FJT} - {1918648800 46800 1 FJST} + {1919253600 46800 1 FJST} {1926511200 43200 0 FJT} - {1950098400 46800 1 FJST} + {1950703200 46800 1 FJST} {1957960800 43200 0 FJT} {1982152800 46800 1 FJST} {1990015200 43200 0 FJT} @@ -61,9 +61,9 @@ set TZData(:Pacific/Fiji) { {2052914400 43200 0 FJT} {2076501600 46800 1 FJST} {2084364000 43200 0 FJT} - {2107951200 46800 1 FJST} + {2108556000 46800 1 FJST} {2115813600 43200 0 FJT} - {2139400800 46800 1 FJST} + {2140005600 46800 1 FJST} {2147868000 43200 0 FJT} {2171455200 46800 1 FJST} {2179317600 43200 0 FJT} @@ -71,11 +71,11 @@ set TZData(:Pacific/Fiji) { {2210767200 43200 0 FJT} {2234354400 46800 1 FJST} {2242216800 43200 0 FJT} - {2265804000 46800 1 FJST} + {2266408800 46800 1 FJST} {2273666400 43200 0 FJT} - {2297253600 46800 1 FJST} + {2297858400 46800 1 FJST} {2305116000 43200 0 FJT} - {2328703200 46800 1 FJST} + {2329308000 46800 1 FJST} {2337170400 43200 0 FJT} {2360757600 46800 1 FJST} {2368620000 43200 0 FJT} @@ -83,9 +83,9 @@ set TZData(:Pacific/Fiji) { {2400069600 43200 0 FJT} {2423656800 46800 1 FJST} {2431519200 43200 0 FJT} - {2455106400 46800 1 FJST} + {2455711200 46800 1 FJST} {2462968800 43200 0 FJT} - {2486556000 46800 1 FJST} + {2487160800 46800 1 FJST} {2495023200 43200 0 FJT} {2518610400 46800 1 FJST} {2526472800 43200 0 FJT} @@ -93,11 +93,11 @@ set TZData(:Pacific/Fiji) { {2557922400 43200 0 FJT} {2581509600 46800 1 FJST} {2589372000 43200 0 FJT} - {2612959200 46800 1 FJST} + {2613564000 46800 1 FJST} {2620821600 43200 0 FJT} - {2644408800 46800 1 FJST} + {2645013600 46800 1 FJST} {2652271200 43200 0 FJT} - {2675858400 46800 1 FJST} + {2676463200 46800 1 FJST} {2684325600 43200 0 FJT} {2707912800 46800 1 FJST} {2715775200 43200 0 FJT} @@ -105,9 +105,9 @@ set TZData(:Pacific/Fiji) { {2747224800 43200 0 FJT} {2770812000 46800 1 FJST} {2778674400 43200 0 FJT} - {2802261600 46800 1 FJST} + {2802866400 46800 1 FJST} {2810124000 43200 0 FJT} - {2833711200 46800 1 FJST} + {2834316000 46800 1 FJST} {2841573600 43200 0 FJT} {2865765600 46800 1 FJST} {2873628000 43200 0 FJT} @@ -117,9 +117,9 @@ set TZData(:Pacific/Fiji) { {2936527200 43200 0 FJT} {2960114400 46800 1 FJST} {2967976800 43200 0 FJT} - {2991564000 46800 1 FJST} + {2992168800 46800 1 FJST} {2999426400 43200 0 FJT} - {3023013600 46800 1 FJST} + {3023618400 46800 1 FJST} {3031480800 43200 0 FJT} {3055068000 46800 1 FJST} {3062930400 43200 0 FJT} @@ -127,11 +127,11 @@ set TZData(:Pacific/Fiji) { {3094380000 43200 0 FJT} {3117967200 46800 1 FJST} {3125829600 43200 0 FJT} - {3149416800 46800 1 FJST} + {3150021600 46800 1 FJST} {3157279200 43200 0 FJT} - {3180866400 46800 1 FJST} + {3181471200 46800 1 FJST} {3188728800 43200 0 FJT} - {3212316000 46800 1 FJST} + {3212920800 46800 1 FJST} {3220783200 43200 0 FJT} {3244370400 46800 1 FJST} {3252232800 43200 0 FJT} @@ -139,9 +139,9 @@ set TZData(:Pacific/Fiji) { {3283682400 43200 0 FJT} {3307269600 46800 1 FJST} {3315132000 43200 0 FJT} - {3338719200 46800 1 FJST} + {3339324000 46800 1 FJST} {3346581600 43200 0 FJT} - {3370168800 46800 1 FJST} + {3370773600 46800 1 FJST} {3378636000 43200 0 FJT} {3402223200 46800 1 FJST} {3410085600 43200 0 FJT} @@ -149,11 +149,11 @@ set TZData(:Pacific/Fiji) { {3441535200 43200 0 FJT} {3465122400 46800 1 FJST} {3472984800 43200 0 FJT} - {3496572000 46800 1 FJST} + {3497176800 46800 1 FJST} {3504434400 43200 0 FJT} - {3528021600 46800 1 FJST} + {3528626400 46800 1 FJST} {3535884000 43200 0 FJT} - {3559471200 46800 1 FJST} + {3560076000 46800 1 FJST} {3567938400 43200 0 FJT} {3591525600 46800 1 FJST} {3599388000 43200 0 FJT} @@ -161,9 +161,9 @@ set TZData(:Pacific/Fiji) { {3630837600 43200 0 FJT} {3654424800 46800 1 FJST} {3662287200 43200 0 FJT} - {3685874400 46800 1 FJST} + {3686479200 46800 1 FJST} {3693736800 43200 0 FJT} - {3717324000 46800 1 FJST} + {3717928800 46800 1 FJST} {3725186400 43200 0 FJT} {3749378400 46800 1 FJST} {3757240800 43200 0 FJT} @@ -173,9 +173,9 @@ set TZData(:Pacific/Fiji) { {3820140000 43200 0 FJT} {3843727200 46800 1 FJST} {3851589600 43200 0 FJT} - {3875176800 46800 1 FJST} + {3875781600 46800 1 FJST} {3883039200 43200 0 FJT} - {3906626400 46800 1 FJST} + {3907231200 46800 1 FJST} {3915093600 43200 0 FJT} {3938680800 46800 1 FJST} {3946543200 43200 0 FJT} @@ -183,9 +183,9 @@ set TZData(:Pacific/Fiji) { {3977992800 43200 0 FJT} {4001580000 46800 1 FJST} {4009442400 43200 0 FJT} - {4033029600 46800 1 FJST} + {4033634400 46800 1 FJST} {4040892000 43200 0 FJT} - {4064479200 46800 1 FJST} + {4065084000 46800 1 FJST} {4072341600 43200 0 FJT} - {4095928800 46800 1 FJST} + {4096533600 46800 1 FJST} } diff --git a/library/tzdata/Pacific/Johnston b/library/tzdata/Pacific/Johnston index 7f9fee4..21ab39a 100644 --- a/library/tzdata/Pacific/Johnston +++ b/library/tzdata/Pacific/Johnston @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Johnston) { - {-9223372036854775808 -36000 0 HST} +if {![info exists TZData(Pacific/Honolulu)]} { + LoadTimeZoneFile Pacific/Honolulu } +set TZData(:Pacific/Johnston) $TZData(:Pacific/Honolulu) -- cgit v0.12 From 40fefcafadb6a8be490c3ec0be0c6ed724cd1845 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 5 Oct 2013 16:28:52 +0000 Subject: Advance to tzdata2013g --- library/tzdata/Africa/Casablanca | 284 ++++++++++++------------------ library/tzdata/Africa/Juba | 40 +---- library/tzdata/America/Anguilla | 7 +- library/tzdata/America/Araguaina | 174 +----------------- library/tzdata/America/Argentina/San_Luis | 2 +- library/tzdata/America/Aruba | 8 +- library/tzdata/America/Cayman | 4 +- library/tzdata/America/Dominica | 7 +- library/tzdata/America/Grand_Turk | 4 +- library/tzdata/America/Grenada | 7 +- library/tzdata/America/Guadeloupe | 7 +- library/tzdata/America/Jamaica | 6 +- library/tzdata/America/Marigot | 6 +- library/tzdata/America/Montserrat | 7 +- library/tzdata/America/St_Barthelemy | 6 +- library/tzdata/America/St_Kitts | 7 +- library/tzdata/America/St_Lucia | 8 +- library/tzdata/America/St_Thomas | 7 +- library/tzdata/America/St_Vincent | 8 +- library/tzdata/America/Tortola | 7 +- library/tzdata/America/Virgin | 6 +- library/tzdata/Antarctica/McMurdo | 258 +-------------------------- library/tzdata/Antarctica/South_Pole | 6 +- library/tzdata/Asia/Amman | 175 +----------------- library/tzdata/Asia/Dili | 2 +- library/tzdata/Asia/Gaza | 174 +++++++++--------- library/tzdata/Asia/Hebron | 174 +++++++++--------- library/tzdata/Asia/Jakarta | 12 +- library/tzdata/Asia/Jayapura | 4 +- library/tzdata/Asia/Makassar | 4 +- library/tzdata/Asia/Pontianak | 12 +- library/tzdata/Europe/Vaduz | 246 +------------------------- library/tzdata/Europe/Zurich | 4 +- library/tzdata/Pacific/Fiji | 78 ++++---- library/tzdata/Pacific/Johnston | 6 +- 35 files changed, 413 insertions(+), 1354 deletions(-) diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 757007c..dec2778 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -36,189 +36,133 @@ set TZData(:Africa/Casablanca) { {1367114400 3600 1 WEST} {1373162400 0 0 WET} {1376100000 3600 1 WEST} - {1380420000 0 0 WET} - {1398564000 3600 1 WEST} + {1382839200 0 0 WET} + {1396144800 3600 1 WEST} {1404007200 0 0 WET} {1406599200 3600 1 WEST} - {1411869600 0 0 WET} - {1430013600 3600 1 WEST} + {1414288800 0 0 WET} + {1427594400 3600 1 WEST} {1434592800 0 0 WET} {1437184800 3600 1 WEST} - {1443319200 0 0 WET} - {1461463200 3600 1 WEST} + {1445738400 0 0 WET} + {1459044000 3600 1 WEST} {1465264800 0 0 WET} {1467856800 3600 1 WEST} - {1474768800 0 0 WET} - {1493517600 3600 1 WEST} + {1477792800 0 0 WET} + {1490493600 3600 1 WEST} {1495850400 0 0 WET} {1498442400 3600 1 WEST} - {1506218400 0 0 WET} - {1524967200 3600 1 WEST} + {1509242400 0 0 WET} + {1521943200 3600 1 WEST} {1526436000 0 0 WET} {1529028000 3600 1 WEST} - {1538272800 0 0 WET} - {1556416800 3600 1 WEST} + {1540692000 0 0 WET} + {1553997600 3600 1 WEST} {1557108000 0 0 WET} {1559700000 3600 1 WEST} - {1569722400 0 0 WET} + {1572141600 0 0 WET} + {1585447200 3600 1 WEST} + {1587693600 0 0 WET} {1590285600 3600 1 WEST} - {1601172000 0 0 WET} + {1603591200 0 0 WET} + {1616896800 3600 1 WEST} + {1618279200 0 0 WET} {1620871200 3600 1 WEST} - {1632621600 0 0 WET} + {1635645600 0 0 WET} + {1648346400 3600 1 WEST} + {1648951200 0 0 WET} {1651543200 3600 1 WEST} - {1664071200 0 0 WET} - {1682820000 3600 1 WEST} - {1695520800 0 0 WET} - {1714269600 3600 1 WEST} - {1727575200 0 0 WET} - {1745719200 3600 1 WEST} - {1759024800 0 0 WET} - {1777168800 3600 1 WEST} - {1790474400 0 0 WET} - {1808618400 3600 1 WEST} - {1821924000 0 0 WET} - {1840672800 3600 1 WEST} - {1853373600 0 0 WET} - {1872122400 3600 1 WEST} - {1885428000 0 0 WET} - {1903572000 3600 1 WEST} - {1916877600 0 0 WET} - {1935021600 3600 1 WEST} - {1948327200 0 0 WET} - {1966471200 3600 1 WEST} - {1979776800 0 0 WET} - {1997920800 3600 1 WEST} - {2011226400 0 0 WET} - {2029975200 3600 1 WEST} - {2042676000 0 0 WET} - {2061424800 3600 1 WEST} - {2074730400 0 0 WET} - {2092874400 3600 1 WEST} - {2106180000 0 0 WET} - {2124324000 3600 1 WEST} - {2137629600 0 0 WET} - {2155773600 3600 1 WEST} - {2169079200 0 0 WET} - {2187223200 3600 1 WEST} - {2200528800 0 0 WET} - {2219277600 3600 1 WEST} - {2232583200 0 0 WET} - {2250727200 3600 1 WEST} - {2264032800 0 0 WET} - {2282176800 3600 1 WEST} - {2295482400 0 0 WET} - {2313626400 3600 1 WEST} - {2326932000 0 0 WET} - {2345076000 3600 1 WEST} - {2358381600 0 0 WET} - {2377130400 3600 1 WEST} - {2389831200 0 0 WET} - {2408580000 3600 1 WEST} - {2421885600 0 0 WET} - {2440029600 3600 1 WEST} - {2453335200 0 0 WET} - {2471479200 3600 1 WEST} - {2484784800 0 0 WET} - {2502928800 3600 1 WEST} - {2516234400 0 0 WET} - {2534378400 3600 1 WEST} - {2547684000 0 0 WET} - {2566432800 3600 1 WEST} - {2579133600 0 0 WET} - {2597882400 3600 1 WEST} - {2611188000 0 0 WET} - {2629332000 3600 1 WEST} - {2642637600 0 0 WET} - {2660781600 3600 1 WEST} - {2674087200 0 0 WET} - {2692231200 3600 1 WEST} - {2705536800 0 0 WET} - {2724285600 3600 1 WEST} - {2736986400 0 0 WET} - {2755735200 3600 1 WEST} - {2769040800 0 0 WET} - {2787184800 3600 1 WEST} - {2800490400 0 0 WET} - {2818634400 3600 1 WEST} - {2831940000 0 0 WET} - {2850084000 3600 1 WEST} - {2863389600 0 0 WET} - {2881533600 3600 1 WEST} - {2894839200 0 0 WET} - {2913588000 3600 1 WEST} - {2926288800 0 0 WET} - {2945037600 3600 1 WEST} - {2958343200 0 0 WET} - {2976487200 3600 1 WEST} - {2989792800 0 0 WET} - {3007936800 3600 1 WEST} - {3021242400 0 0 WET} - {3039386400 3600 1 WEST} - {3052692000 0 0 WET} - {3070836000 3600 1 WEST} - {3084141600 0 0 WET} - {3102890400 3600 1 WEST} - {3116196000 0 0 WET} - {3134340000 3600 1 WEST} - {3147645600 0 0 WET} - {3165789600 3600 1 WEST} - {3179095200 0 0 WET} - {3197239200 3600 1 WEST} - {3210544800 0 0 WET} - {3228688800 3600 1 WEST} - {3241994400 0 0 WET} - {3260743200 3600 1 WEST} - {3273444000 0 0 WET} - {3292192800 3600 1 WEST} - {3305498400 0 0 WET} - {3323642400 3600 1 WEST} - {3336948000 0 0 WET} - {3355092000 3600 1 WEST} - {3368397600 0 0 WET} - {3386541600 3600 1 WEST} - {3399847200 0 0 WET} - {3417991200 3600 1 WEST} - {3431296800 0 0 WET} - {3450045600 3600 1 WEST} - {3462746400 0 0 WET} - {3481495200 3600 1 WEST} - {3494800800 0 0 WET} - {3512944800 3600 1 WEST} - {3526250400 0 0 WET} - {3544394400 3600 1 WEST} - {3557700000 0 0 WET} - {3575844000 3600 1 WEST} - {3589149600 0 0 WET} - {3607898400 3600 1 WEST} - {3620599200 0 0 WET} - {3639348000 3600 1 WEST} - {3652653600 0 0 WET} - {3670797600 3600 1 WEST} - {3684103200 0 0 WET} - {3702247200 3600 1 WEST} - {3715552800 0 0 WET} - {3733696800 3600 1 WEST} - {3747002400 0 0 WET} - {3765146400 3600 1 WEST} - {3778452000 0 0 WET} - {3797200800 3600 1 WEST} - {3809901600 0 0 WET} - {3828650400 3600 1 WEST} - {3841956000 0 0 WET} - {3860100000 3600 1 WEST} - {3873405600 0 0 WET} - {3891549600 3600 1 WEST} - {3904855200 0 0 WET} - {3922999200 3600 1 WEST} - {3936304800 0 0 WET} - {3954448800 3600 1 WEST} - {3967754400 0 0 WET} - {3986503200 3600 1 WEST} - {3999808800 0 0 WET} - {4017952800 3600 1 WEST} - {4031258400 0 0 WET} - {4049402400 3600 1 WEST} - {4062708000 0 0 WET} - {4080852000 3600 1 WEST} - {4094157600 0 0 WET} + {1667095200 0 0 WET} + {1682128800 3600 1 WEST} + {1698544800 0 0 WET} + {1712714400 3600 1 WEST} + {1729994400 0 0 WET} + {1743386400 3600 1 WEST} + {1761444000 0 0 WET} + {1774749600 3600 1 WEST} + {1792893600 0 0 WET} + {1806199200 3600 1 WEST} + {1824948000 0 0 WET} + {1837648800 3600 1 WEST} + {1856397600 0 0 WET} + {1869098400 3600 1 WEST} + {1887847200 0 0 WET} + {1901152800 3600 1 WEST} + {1919296800 0 0 WET} + {1932602400 3600 1 WEST} + {1950746400 0 0 WET} + {1964052000 3600 1 WEST} + {1982800800 0 0 WET} + {1995501600 3600 1 WEST} + {2014250400 0 0 WET} + {2026951200 3600 1 WEST} + {2045700000 0 0 WET} + {2058400800 3600 1 WEST} + {2077149600 0 0 WET} + {2090455200 3600 1 WEST} + {2108167200 0 0 WET} + {2121904800 3600 1 WEST} + {2138839200 0 0 WET} + {2153354400 3600 1 WEST} + {2184800400 3600 1 WEST} + {2216250000 3600 1 WEST} + {2248304400 3600 1 WEST} + {2279754000 3600 1 WEST} + {2311203600 3600 1 WEST} + {2342653200 3600 1 WEST} + {2374102800 3600 1 WEST} + {2405552400 3600 1 WEST} + {2437606800 3600 1 WEST} + {2469056400 3600 1 WEST} + {2500506000 3600 1 WEST} + {2531955600 3600 1 WEST} + {2563405200 3600 1 WEST} + {2595459600 3600 1 WEST} + {2626909200 3600 1 WEST} + {2658358800 3600 1 WEST} + {2689808400 3600 1 WEST} + {2721258000 3600 1 WEST} + {2752707600 3600 1 WEST} + {2784762000 3600 1 WEST} + {2816211600 3600 1 WEST} + {2847661200 3600 1 WEST} + {2879110800 3600 1 WEST} + {2910560400 3600 1 WEST} + {2942010000 3600 1 WEST} + {2974064400 3600 1 WEST} + {3005514000 3600 1 WEST} + {3036963600 3600 1 WEST} + {3068413200 3600 1 WEST} + {3099862800 3600 1 WEST} + {3131917200 3600 1 WEST} + {3163366800 3600 1 WEST} + {3194816400 3600 1 WEST} + {3226266000 3600 1 WEST} + {3257715600 3600 1 WEST} + {3289165200 3600 1 WEST} + {3321219600 3600 1 WEST} + {3352669200 3600 1 WEST} + {3384118800 3600 1 WEST} + {3415568400 3600 1 WEST} + {3447018000 3600 1 WEST} + {3479072400 3600 1 WEST} + {3510522000 3600 1 WEST} + {3541971600 3600 1 WEST} + {3573421200 3600 1 WEST} + {3604870800 3600 1 WEST} + {3636320400 3600 1 WEST} + {3668374800 3600 1 WEST} + {3699824400 3600 1 WEST} + {3731274000 3600 1 WEST} + {3762723600 3600 1 WEST} + {3794173200 3600 1 WEST} + {3825622800 3600 1 WEST} + {3857677200 3600 1 WEST} + {3889126800 3600 1 WEST} + {3920576400 3600 1 WEST} + {3952026000 3600 1 WEST} + {3983475600 3600 1 WEST} + {4015530000 3600 1 WEST} + {4046979600 3600 1 WEST} + {4078429200 3600 1 WEST} } diff --git a/library/tzdata/Africa/Juba b/library/tzdata/Africa/Juba index 7495981..40551f2 100644 --- a/library/tzdata/Africa/Juba +++ b/library/tzdata/Africa/Juba @@ -1,39 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Africa/Juba) { - {-9223372036854775808 7584 0 LMT} - {-1230775584 7200 0 CAT} - {10360800 10800 1 CAST} - {24786000 7200 0 CAT} - {41810400 10800 1 CAST} - {56322000 7200 0 CAT} - {73432800 10800 1 CAST} - {87944400 7200 0 CAT} - {104882400 10800 1 CAST} - {119480400 7200 0 CAT} - {136332000 10800 1 CAST} - {151016400 7200 0 CAT} - {167781600 10800 1 CAST} - {182552400 7200 0 CAT} - {199231200 10800 1 CAST} - {214174800 7200 0 CAT} - {230680800 10800 1 CAST} - {245710800 7200 0 CAT} - {262735200 10800 1 CAST} - {277246800 7200 0 CAT} - {294184800 10800 1 CAST} - {308782800 7200 0 CAT} - {325634400 10800 1 CAST} - {340405200 7200 0 CAT} - {357084000 10800 1 CAST} - {371941200 7200 0 CAT} - {388533600 10800 1 CAST} - {403477200 7200 0 CAT} - {419983200 10800 1 CAST} - {435013200 7200 0 CAT} - {452037600 10800 1 CAST} - {466635600 7200 0 CAT} - {483487200 10800 1 CAST} - {498171600 7200 0 CAT} - {947930400 10800 0 EAT} +if {![info exists TZData(Africa/Khartoum)]} { + LoadTimeZoneFile Africa/Khartoum } +set TZData(:Africa/Juba) $TZData(:Africa/Khartoum) diff --git a/library/tzdata/America/Anguilla b/library/tzdata/America/Anguilla index cfe7483..39a0d18 100644 --- a/library/tzdata/America/Anguilla +++ b/library/tzdata/America/Anguilla @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Anguilla) { - {-9223372036854775808 -15136 0 LMT} - {-1825098464 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Anguilla) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Araguaina b/library/tzdata/America/Araguaina index dc1b543..e4a0d52 100644 --- a/library/tzdata/America/Araguaina +++ b/library/tzdata/America/Araguaina @@ -56,177 +56,5 @@ set TZData(:America/Araguaina) { {1064368800 -10800 0 BRT} {1350788400 -7200 0 BRST} {1361066400 -10800 0 BRT} - {1382238000 -7200 1 BRST} - {1392516000 -10800 0 BRT} - {1413687600 -7200 1 BRST} - {1424570400 -10800 0 BRT} - {1445137200 -7200 1 BRST} - {1456020000 -10800 0 BRT} - {1476586800 -7200 1 BRST} - {1487469600 -10800 0 BRT} - {1508036400 -7200 1 BRST} - {1518919200 -10800 0 BRT} - {1540090800 -7200 1 BRST} - {1550368800 -10800 0 BRT} - {1571540400 -7200 1 BRST} - {1581818400 -10800 0 BRT} - {1602990000 -7200 1 BRST} - {1613872800 -10800 0 BRT} - {1634439600 -7200 1 BRST} - {1645322400 -10800 0 BRT} - {1665889200 -7200 1 BRST} - {1677376800 -10800 0 BRT} - {1697338800 -7200 1 BRST} - {1708221600 -10800 0 BRT} - {1729393200 -7200 1 BRST} - {1739671200 -10800 0 BRT} - {1760842800 -7200 1 BRST} - {1771725600 -10800 0 BRT} - {1792292400 -7200 1 BRST} - {1803175200 -10800 0 BRT} - {1823742000 -7200 1 BRST} - {1834624800 -10800 0 BRT} - {1855191600 -7200 1 BRST} - {1866074400 -10800 0 BRT} - {1887246000 -7200 1 BRST} - {1897524000 -10800 0 BRT} - {1918695600 -7200 1 BRST} - {1928973600 -10800 0 BRT} - {1950145200 -7200 1 BRST} - {1960423200 -10800 0 BRT} - {1981594800 -7200 1 BRST} - {1992477600 -10800 0 BRT} - {2013044400 -7200 1 BRST} - {2024532000 -10800 0 BRT} - {2044494000 -7200 1 BRST} - {2055376800 -10800 0 BRT} - {2076548400 -7200 1 BRST} - {2086826400 -10800 0 BRT} - {2107998000 -7200 1 BRST} - {2118880800 -10800 0 BRT} - {2139447600 -7200 1 BRST} - {2150330400 -10800 0 BRT} - {2170897200 -7200 1 BRST} - {2181780000 -10800 0 BRT} - {2202346800 -7200 1 BRST} - {2213229600 -10800 0 BRT} - {2234401200 -7200 1 BRST} - {2244679200 -10800 0 BRT} - {2265850800 -7200 1 BRST} - {2276128800 -10800 0 BRT} - {2297300400 -7200 1 BRST} - {2307578400 -10800 0 BRT} - {2328750000 -7200 1 BRST} - {2339632800 -10800 0 BRT} - {2360199600 -7200 1 BRST} - {2371082400 -10800 0 BRT} - {2391649200 -7200 1 BRST} - {2402532000 -10800 0 BRT} - {2423703600 -7200 1 BRST} - {2433981600 -10800 0 BRT} - {2455153200 -7200 1 BRST} - {2465431200 -10800 0 BRT} - {2486602800 -7200 1 BRST} - {2497485600 -10800 0 BRT} - {2518052400 -7200 1 BRST} - {2528935200 -10800 0 BRT} - {2549502000 -7200 1 BRST} - {2560384800 -10800 0 BRT} - {2580951600 -7200 1 BRST} - {2591834400 -10800 0 BRT} - {2613006000 -7200 1 BRST} - {2623284000 -10800 0 BRT} - {2644455600 -7200 1 BRST} - {2654733600 -10800 0 BRT} - {2675905200 -7200 1 BRST} - {2686788000 -10800 0 BRT} - {2707354800 -7200 1 BRST} - {2718237600 -10800 0 BRT} - {2738804400 -7200 1 BRST} - {2749687200 -10800 0 BRT} - {2770858800 -7200 1 BRST} - {2781136800 -10800 0 BRT} - {2802308400 -7200 1 BRST} - {2812586400 -10800 0 BRT} - {2833758000 -7200 1 BRST} - {2844036000 -10800 0 BRT} - {2865207600 -7200 1 BRST} - {2876090400 -10800 0 BRT} - {2896657200 -7200 1 BRST} - {2907540000 -10800 0 BRT} - {2928106800 -7200 1 BRST} - {2938989600 -10800 0 BRT} - {2960161200 -7200 1 BRST} - {2970439200 -10800 0 BRT} - {2991610800 -7200 1 BRST} - {3001888800 -10800 0 BRT} - {3023060400 -7200 1 BRST} - {3033943200 -10800 0 BRT} - {3054510000 -7200 1 BRST} - {3065392800 -10800 0 BRT} - {3085959600 -7200 1 BRST} - {3096842400 -10800 0 BRT} - {3118014000 -7200 1 BRST} - {3128292000 -10800 0 BRT} - {3149463600 -7200 1 BRST} - {3159741600 -10800 0 BRT} - {3180913200 -7200 1 BRST} - {3191191200 -10800 0 BRT} - {3212362800 -7200 1 BRST} - {3223245600 -10800 0 BRT} - {3243812400 -7200 1 BRST} - {3254695200 -10800 0 BRT} - {3275262000 -7200 1 BRST} - {3286144800 -10800 0 BRT} - {3307316400 -7200 1 BRST} - {3317594400 -10800 0 BRT} - {3338766000 -7200 1 BRST} - {3349044000 -10800 0 BRT} - {3370215600 -7200 1 BRST} - {3381098400 -10800 0 BRT} - {3401665200 -7200 1 BRST} - {3412548000 -10800 0 BRT} - {3433114800 -7200 1 BRST} - {3443997600 -10800 0 BRT} - {3464564400 -7200 1 BRST} - {3475447200 -10800 0 BRT} - {3496618800 -7200 1 BRST} - {3506896800 -10800 0 BRT} - {3528068400 -7200 1 BRST} - {3538346400 -10800 0 BRT} - {3559518000 -7200 1 BRST} - {3570400800 -10800 0 BRT} - {3590967600 -7200 1 BRST} - {3601850400 -10800 0 BRT} - {3622417200 -7200 1 BRST} - {3633300000 -10800 0 BRT} - {3654471600 -7200 1 BRST} - {3664749600 -10800 0 BRT} - {3685921200 -7200 1 BRST} - {3696199200 -10800 0 BRT} - {3717370800 -7200 1 BRST} - {3727648800 -10800 0 BRT} - {3748820400 -7200 1 BRST} - {3759703200 -10800 0 BRT} - {3780270000 -7200 1 BRST} - {3791152800 -10800 0 BRT} - {3811719600 -7200 1 BRST} - {3822602400 -10800 0 BRT} - {3843774000 -7200 1 BRST} - {3854052000 -10800 0 BRT} - {3875223600 -7200 1 BRST} - {3885501600 -10800 0 BRT} - {3906673200 -7200 1 BRST} - {3917556000 -10800 0 BRT} - {3938122800 -7200 1 BRST} - {3949005600 -10800 0 BRT} - {3969572400 -7200 1 BRST} - {3980455200 -10800 0 BRT} - {4001626800 -7200 1 BRST} - {4011904800 -10800 0 BRT} - {4033076400 -7200 1 BRST} - {4043354400 -10800 0 BRT} - {4064526000 -7200 1 BRST} - {4074804000 -10800 0 BRT} - {4095975600 -7200 1 BRST} + {1378000800 -10800 0 BRT} } diff --git a/library/tzdata/America/Argentina/San_Luis b/library/tzdata/America/Argentina/San_Luis index bec1554..8ca55d7 100644 --- a/library/tzdata/America/Argentina/San_Luis +++ b/library/tzdata/America/Argentina/San_Luis @@ -64,5 +64,5 @@ set TZData(:America/Argentina/San_Luis) { {1205031600 -14400 0 WART} {1223784000 -10800 1 WARST} {1236481200 -14400 0 WART} - {1255233600 -10800 1 WARST} + {1255233600 -10800 0 ART} } diff --git a/library/tzdata/America/Aruba b/library/tzdata/America/Aruba index 92f182d..e02d5fc 100644 --- a/library/tzdata/America/Aruba +++ b/library/tzdata/America/Aruba @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Aruba) { - {-9223372036854775808 -16824 0 LMT} - {-1826738376 -16200 0 ANT} - {-157750200 -14400 0 AST} +if {![info exists TZData(America/Curacao)]} { + LoadTimeZoneFile America/Curacao } +set TZData(:America/Aruba) $TZData(:America/Curacao) diff --git a/library/tzdata/America/Cayman b/library/tzdata/America/Cayman index ab5d12b..3e2e3cc 100644 --- a/library/tzdata/America/Cayman +++ b/library/tzdata/America/Cayman @@ -2,6 +2,6 @@ set TZData(:America/Cayman) { {-9223372036854775808 -19532 0 LMT} - {-2524502068 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-2524502068 -18431 0 KMT} + {-1827687169 -18000 0 EST} } diff --git a/library/tzdata/America/Dominica b/library/tzdata/America/Dominica index 3503a65..b97cb0e 100644 --- a/library/tzdata/America/Dominica +++ b/library/tzdata/America/Dominica @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Dominica) { - {-9223372036854775808 -14736 0 LMT} - {-1846266804 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Dominica) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Grand_Turk b/library/tzdata/America/Grand_Turk index a455dd5..6c8ea4a 100644 --- a/library/tzdata/America/Grand_Turk +++ b/library/tzdata/America/Grand_Turk @@ -2,8 +2,8 @@ set TZData(:America/Grand_Turk) { {-9223372036854775808 -17072 0 LMT} - {-2524504528 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-2524504528 -18431 0 KMT} + {-1827687169 -18000 0 EST} {294217200 -14400 1 EDT} {309938400 -18000 0 EST} {325666800 -14400 1 EDT} diff --git a/library/tzdata/America/Grenada b/library/tzdata/America/Grenada index 3c2919b..92300c3 100644 --- a/library/tzdata/America/Grenada +++ b/library/tzdata/America/Grenada @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Grenada) { - {-9223372036854775808 -14820 0 LMT} - {-1846266780 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Grenada) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Guadeloupe b/library/tzdata/America/Guadeloupe index b1987ce..aba6bd7 100644 --- a/library/tzdata/America/Guadeloupe +++ b/library/tzdata/America/Guadeloupe @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Guadeloupe) { - {-9223372036854775808 -14768 0 LMT} - {-1848254032 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Guadeloupe) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Jamaica b/library/tzdata/America/Jamaica index 393d90a8..682e47c 100644 --- a/library/tzdata/America/Jamaica +++ b/library/tzdata/America/Jamaica @@ -1,9 +1,9 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:America/Jamaica) { - {-9223372036854775808 -18432 0 LMT} - {-2524503168 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-9223372036854775808 -18431 0 LMT} + {-2524503169 -18431 0 KMT} + {-1827687169 -18000 0 EST} {136364400 -14400 0 EDT} {152085600 -18000 0 EST} {162370800 -14400 1 EDT} diff --git a/library/tzdata/America/Marigot b/library/tzdata/America/Marigot index 9f3f8f6..c2b3873 100644 --- a/library/tzdata/America/Marigot +++ b/library/tzdata/America/Marigot @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Guadeloupe)]} { - LoadTimeZoneFile America/Guadeloupe +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/Marigot) $TZData(:America/Guadeloupe) +set TZData(:America/Marigot) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Montserrat b/library/tzdata/America/Montserrat index 4d82766..0a656d3 100644 --- a/library/tzdata/America/Montserrat +++ b/library/tzdata/America/Montserrat @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Montserrat) { - {-9223372036854775808 -14932 0 LMT} - {-1846266608 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Montserrat) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Barthelemy b/library/tzdata/America/St_Barthelemy index 25c114a..46bc287 100644 --- a/library/tzdata/America/St_Barthelemy +++ b/library/tzdata/America/St_Barthelemy @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Guadeloupe)]} { - LoadTimeZoneFile America/Guadeloupe +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/St_Barthelemy) $TZData(:America/Guadeloupe) +set TZData(:America/St_Barthelemy) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Kitts b/library/tzdata/America/St_Kitts index bfd803b..6ad7f04 100644 --- a/library/tzdata/America/St_Kitts +++ b/library/tzdata/America/St_Kitts @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Kitts) { - {-9223372036854775808 -15052 0 LMT} - {-1825098548 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Kitts) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Lucia b/library/tzdata/America/St_Lucia index c2767dd..e479b31 100644 --- a/library/tzdata/America/St_Lucia +++ b/library/tzdata/America/St_Lucia @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Lucia) { - {-9223372036854775808 -14640 0 LMT} - {-2524506960 -14640 0 CMT} - {-1830369360 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Lucia) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Thomas b/library/tzdata/America/St_Thomas index bf93595..24698b8 100644 --- a/library/tzdata/America/St_Thomas +++ b/library/tzdata/America/St_Thomas @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Thomas) { - {-9223372036854775808 -15584 0 LMT} - {-1846266016 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Thomas) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Vincent b/library/tzdata/America/St_Vincent index 3a884c7..e3b32fb 100644 --- a/library/tzdata/America/St_Vincent +++ b/library/tzdata/America/St_Vincent @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Vincent) { - {-9223372036854775808 -14696 0 LMT} - {-2524506904 -14696 0 KMT} - {-1830369304 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Vincent) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Tortola b/library/tzdata/America/Tortola index bf7f1fc..aa6f655 100644 --- a/library/tzdata/America/Tortola +++ b/library/tzdata/America/Tortola @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Tortola) { - {-9223372036854775808 -15508 0 LMT} - {-1846266092 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Tortola) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Virgin b/library/tzdata/America/Virgin index 390d7c2..c267e5b 100644 --- a/library/tzdata/America/Virgin +++ b/library/tzdata/America/Virgin @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/St_Thomas)]} { - LoadTimeZoneFile America/St_Thomas +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/Virgin) $TZData(:America/St_Thomas) +set TZData(:America/Virgin) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/Antarctica/McMurdo b/library/tzdata/Antarctica/McMurdo index 670f7eb..3b29ba1 100644 --- a/library/tzdata/Antarctica/McMurdo +++ b/library/tzdata/Antarctica/McMurdo @@ -1,257 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Antarctica/McMurdo) { - {-9223372036854775808 0 0 zzz} - {-441849600 43200 0 NZST} - {152632800 46800 1 NZDT} - {162309600 43200 0 NZST} - {183477600 46800 1 NZDT} - {194968800 43200 0 NZST} - {215532000 46800 1 NZDT} - {226418400 43200 0 NZST} - {246981600 46800 1 NZDT} - {257868000 43200 0 NZST} - {278431200 46800 1 NZDT} - {289317600 43200 0 NZST} - {309880800 46800 1 NZDT} - {320767200 43200 0 NZST} - {341330400 46800 1 NZDT} - {352216800 43200 0 NZST} - {372780000 46800 1 NZDT} - {384271200 43200 0 NZST} - {404834400 46800 1 NZDT} - {415720800 43200 0 NZST} - {436284000 46800 1 NZDT} - {447170400 43200 0 NZST} - {467733600 46800 1 NZDT} - {478620000 43200 0 NZST} - {499183200 46800 1 NZDT} - {510069600 43200 0 NZST} - {530632800 46800 1 NZDT} - {541519200 43200 0 NZST} - {562082400 46800 1 NZDT} - {573573600 43200 0 NZST} - {594136800 46800 1 NZDT} - {605023200 43200 0 NZST} - {623772000 46800 1 NZDT} - {637682400 43200 0 NZST} - {655221600 46800 1 NZDT} - {669132000 43200 0 NZST} - {686671200 46800 1 NZDT} - {700581600 43200 0 NZST} - {718120800 46800 1 NZDT} - {732636000 43200 0 NZST} - {749570400 46800 1 NZDT} - {764085600 43200 0 NZST} - {781020000 46800 1 NZDT} - {795535200 43200 0 NZST} - {812469600 46800 1 NZDT} - {826984800 43200 0 NZST} - {844524000 46800 1 NZDT} - {858434400 43200 0 NZST} - {875973600 46800 1 NZDT} - {889884000 43200 0 NZST} - {907423200 46800 1 NZDT} - {921938400 43200 0 NZST} - {938872800 46800 1 NZDT} - {953388000 43200 0 NZST} - {970322400 46800 1 NZDT} - {984837600 43200 0 NZST} - {1002376800 46800 1 NZDT} - {1016287200 43200 0 NZST} - {1033826400 46800 1 NZDT} - {1047736800 43200 0 NZST} - {1065276000 46800 1 NZDT} - {1079791200 43200 0 NZST} - {1096725600 46800 1 NZDT} - {1111240800 43200 0 NZST} - {1128175200 46800 1 NZDT} - {1142690400 43200 0 NZST} - {1159624800 46800 1 NZDT} - {1174140000 43200 0 NZST} - {1191074400 46800 1 NZDT} - {1207404000 43200 0 NZST} - {1222524000 46800 1 NZDT} - {1238853600 43200 0 NZST} - {1253973600 46800 1 NZDT} - {1270303200 43200 0 NZST} - {1285423200 46800 1 NZDT} - {1301752800 43200 0 NZST} - {1316872800 46800 1 NZDT} - {1333202400 43200 0 NZST} - {1348927200 46800 1 NZDT} - {1365256800 43200 0 NZST} - {1380376800 46800 1 NZDT} - {1396706400 43200 0 NZST} - {1411826400 46800 1 NZDT} - {1428156000 43200 0 NZST} - {1443276000 46800 1 NZDT} - {1459605600 43200 0 NZST} - {1474725600 46800 1 NZDT} - {1491055200 43200 0 NZST} - {1506175200 46800 1 NZDT} - {1522504800 43200 0 NZST} - {1538229600 46800 1 NZDT} - {1554559200 43200 0 NZST} - {1569679200 46800 1 NZDT} - {1586008800 43200 0 NZST} - {1601128800 46800 1 NZDT} - {1617458400 43200 0 NZST} - {1632578400 46800 1 NZDT} - {1648908000 43200 0 NZST} - {1664028000 46800 1 NZDT} - {1680357600 43200 0 NZST} - {1695477600 46800 1 NZDT} - {1712412000 43200 0 NZST} - {1727532000 46800 1 NZDT} - {1743861600 43200 0 NZST} - {1758981600 46800 1 NZDT} - {1775311200 43200 0 NZST} - {1790431200 46800 1 NZDT} - {1806760800 43200 0 NZST} - {1821880800 46800 1 NZDT} - {1838210400 43200 0 NZST} - {1853330400 46800 1 NZDT} - {1869660000 43200 0 NZST} - {1885384800 46800 1 NZDT} - {1901714400 43200 0 NZST} - {1916834400 46800 1 NZDT} - {1933164000 43200 0 NZST} - {1948284000 46800 1 NZDT} - {1964613600 43200 0 NZST} - {1979733600 46800 1 NZDT} - {1996063200 43200 0 NZST} - {2011183200 46800 1 NZDT} - {2027512800 43200 0 NZST} - {2042632800 46800 1 NZDT} - {2058962400 43200 0 NZST} - {2074687200 46800 1 NZDT} - {2091016800 43200 0 NZST} - {2106136800 46800 1 NZDT} - {2122466400 43200 0 NZST} - {2137586400 46800 1 NZDT} - {2153916000 43200 0 NZST} - {2169036000 46800 1 NZDT} - {2185365600 43200 0 NZST} - {2200485600 46800 1 NZDT} - {2216815200 43200 0 NZST} - {2232540000 46800 1 NZDT} - {2248869600 43200 0 NZST} - {2263989600 46800 1 NZDT} - {2280319200 43200 0 NZST} - {2295439200 46800 1 NZDT} - {2311768800 43200 0 NZST} - {2326888800 46800 1 NZDT} - {2343218400 43200 0 NZST} - {2358338400 46800 1 NZDT} - {2374668000 43200 0 NZST} - {2389788000 46800 1 NZDT} - {2406117600 43200 0 NZST} - {2421842400 46800 1 NZDT} - {2438172000 43200 0 NZST} - {2453292000 46800 1 NZDT} - {2469621600 43200 0 NZST} - {2484741600 46800 1 NZDT} - {2501071200 43200 0 NZST} - {2516191200 46800 1 NZDT} - {2532520800 43200 0 NZST} - {2547640800 46800 1 NZDT} - {2563970400 43200 0 NZST} - {2579090400 46800 1 NZDT} - {2596024800 43200 0 NZST} - {2611144800 46800 1 NZDT} - {2627474400 43200 0 NZST} - {2642594400 46800 1 NZDT} - {2658924000 43200 0 NZST} - {2674044000 46800 1 NZDT} - {2690373600 43200 0 NZST} - {2705493600 46800 1 NZDT} - {2721823200 43200 0 NZST} - {2736943200 46800 1 NZDT} - {2753272800 43200 0 NZST} - {2768997600 46800 1 NZDT} - {2785327200 43200 0 NZST} - {2800447200 46800 1 NZDT} - {2816776800 43200 0 NZST} - {2831896800 46800 1 NZDT} - {2848226400 43200 0 NZST} - {2863346400 46800 1 NZDT} - {2879676000 43200 0 NZST} - {2894796000 46800 1 NZDT} - {2911125600 43200 0 NZST} - {2926245600 46800 1 NZDT} - {2942575200 43200 0 NZST} - {2958300000 46800 1 NZDT} - {2974629600 43200 0 NZST} - {2989749600 46800 1 NZDT} - {3006079200 43200 0 NZST} - {3021199200 46800 1 NZDT} - {3037528800 43200 0 NZST} - {3052648800 46800 1 NZDT} - {3068978400 43200 0 NZST} - {3084098400 46800 1 NZDT} - {3100428000 43200 0 NZST} - {3116152800 46800 1 NZDT} - {3132482400 43200 0 NZST} - {3147602400 46800 1 NZDT} - {3163932000 43200 0 NZST} - {3179052000 46800 1 NZDT} - {3195381600 43200 0 NZST} - {3210501600 46800 1 NZDT} - {3226831200 43200 0 NZST} - {3241951200 46800 1 NZDT} - {3258280800 43200 0 NZST} - {3273400800 46800 1 NZDT} - {3289730400 43200 0 NZST} - {3305455200 46800 1 NZDT} - {3321784800 43200 0 NZST} - {3336904800 46800 1 NZDT} - {3353234400 43200 0 NZST} - {3368354400 46800 1 NZDT} - {3384684000 43200 0 NZST} - {3399804000 46800 1 NZDT} - {3416133600 43200 0 NZST} - {3431253600 46800 1 NZDT} - {3447583200 43200 0 NZST} - {3462703200 46800 1 NZDT} - {3479637600 43200 0 NZST} - {3494757600 46800 1 NZDT} - {3511087200 43200 0 NZST} - {3526207200 46800 1 NZDT} - {3542536800 43200 0 NZST} - {3557656800 46800 1 NZDT} - {3573986400 43200 0 NZST} - {3589106400 46800 1 NZDT} - {3605436000 43200 0 NZST} - {3620556000 46800 1 NZDT} - {3636885600 43200 0 NZST} - {3652610400 46800 1 NZDT} - {3668940000 43200 0 NZST} - {3684060000 46800 1 NZDT} - {3700389600 43200 0 NZST} - {3715509600 46800 1 NZDT} - {3731839200 43200 0 NZST} - {3746959200 46800 1 NZDT} - {3763288800 43200 0 NZST} - {3778408800 46800 1 NZDT} - {3794738400 43200 0 NZST} - {3809858400 46800 1 NZDT} - {3826188000 43200 0 NZST} - {3841912800 46800 1 NZDT} - {3858242400 43200 0 NZST} - {3873362400 46800 1 NZDT} - {3889692000 43200 0 NZST} - {3904812000 46800 1 NZDT} - {3921141600 43200 0 NZST} - {3936261600 46800 1 NZDT} - {3952591200 43200 0 NZST} - {3967711200 46800 1 NZDT} - {3984040800 43200 0 NZST} - {3999765600 46800 1 NZDT} - {4016095200 43200 0 NZST} - {4031215200 46800 1 NZDT} - {4047544800 43200 0 NZST} - {4062664800 46800 1 NZDT} - {4078994400 43200 0 NZST} - {4094114400 46800 1 NZDT} +if {![info exists TZData(Pacific/Auckland)]} { + LoadTimeZoneFile Pacific/Auckland } +set TZData(:Antarctica/McMurdo) $TZData(:Pacific/Auckland) diff --git a/library/tzdata/Antarctica/South_Pole b/library/tzdata/Antarctica/South_Pole index 34d0db1..544bde4 100644 --- a/library/tzdata/Antarctica/South_Pole +++ b/library/tzdata/Antarctica/South_Pole @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Antarctica/McMurdo)]} { - LoadTimeZoneFile Antarctica/McMurdo +if {![info exists TZData(Pacific/Auckland)]} { + LoadTimeZoneFile Pacific/Auckland } -set TZData(:Antarctica/South_Pole) $TZData(:Antarctica/McMurdo) +set TZData(:Antarctica/South_Pole) $TZData(:Pacific/Auckland) diff --git a/library/tzdata/Asia/Amman b/library/tzdata/Asia/Amman index 33f0ba7..d5e8616 100644 --- a/library/tzdata/Asia/Amman +++ b/library/tzdata/Asia/Amman @@ -70,178 +70,5 @@ set TZData(:Asia/Amman) { {1301608800 10800 1 EEST} {1319752800 7200 0 EET} {1333058400 10800 1 EEST} - {1364504400 10800 1 EEST} - {1382652000 7200 0 EET} - {1395957600 10800 1 EEST} - {1414706400 7200 0 EET} - {1427407200 10800 1 EEST} - {1446156000 7200 0 EET} - {1459461600 10800 1 EEST} - {1477605600 7200 0 EET} - {1490911200 10800 1 EEST} - {1509055200 7200 0 EET} - {1522360800 10800 1 EEST} - {1540504800 7200 0 EET} - {1553810400 10800 1 EEST} - {1571954400 7200 0 EET} - {1585260000 10800 1 EEST} - {1604008800 7200 0 EET} - {1616709600 10800 1 EEST} - {1635458400 7200 0 EET} - {1648764000 10800 1 EEST} - {1666908000 7200 0 EET} - {1680213600 10800 1 EEST} - {1698357600 7200 0 EET} - {1711663200 10800 1 EEST} - {1729807200 7200 0 EET} - {1743112800 10800 1 EEST} - {1761861600 7200 0 EET} - {1774562400 10800 1 EEST} - {1793311200 7200 0 EET} - {1806012000 10800 1 EEST} - {1824760800 7200 0 EET} - {1838066400 10800 1 EEST} - {1856210400 7200 0 EET} - {1869516000 10800 1 EEST} - {1887660000 7200 0 EET} - {1900965600 10800 1 EEST} - {1919109600 7200 0 EET} - {1932415200 10800 1 EEST} - {1951164000 7200 0 EET} - {1963864800 10800 1 EEST} - {1982613600 7200 0 EET} - {1995919200 10800 1 EEST} - {2014063200 7200 0 EET} - {2027368800 10800 1 EEST} - {2045512800 7200 0 EET} - {2058818400 10800 1 EEST} - {2076962400 7200 0 EET} - {2090268000 10800 1 EEST} - {2109016800 7200 0 EET} - {2121717600 10800 1 EEST} - {2140466400 7200 0 EET} - {2153167200 10800 1 EEST} - {2171916000 7200 0 EET} - {2185221600 10800 1 EEST} - {2203365600 7200 0 EET} - {2216671200 10800 1 EEST} - {2234815200 7200 0 EET} - {2248120800 10800 1 EEST} - {2266264800 7200 0 EET} - {2279570400 10800 1 EEST} - {2298319200 7200 0 EET} - {2311020000 10800 1 EEST} - {2329768800 7200 0 EET} - {2343074400 10800 1 EEST} - {2361218400 7200 0 EET} - {2374524000 10800 1 EEST} - {2392668000 7200 0 EET} - {2405973600 10800 1 EEST} - {2424117600 7200 0 EET} - {2437423200 10800 1 EEST} - {2455567200 7200 0 EET} - {2468872800 10800 1 EEST} - {2487621600 7200 0 EET} - {2500322400 10800 1 EEST} - {2519071200 7200 0 EET} - {2532376800 10800 1 EEST} - {2550520800 7200 0 EET} - {2563826400 10800 1 EEST} - {2581970400 7200 0 EET} - {2595276000 10800 1 EEST} - {2613420000 7200 0 EET} - {2626725600 10800 1 EEST} - {2645474400 7200 0 EET} - {2658175200 10800 1 EEST} - {2676924000 7200 0 EET} - {2689624800 10800 1 EEST} - {2708373600 7200 0 EET} - {2721679200 10800 1 EEST} - {2739823200 7200 0 EET} - {2753128800 10800 1 EEST} - {2771272800 7200 0 EET} - {2784578400 10800 1 EEST} - {2802722400 7200 0 EET} - {2816028000 10800 1 EEST} - {2834776800 7200 0 EET} - {2847477600 10800 1 EEST} - {2866226400 7200 0 EET} - {2879532000 10800 1 EEST} - {2897676000 7200 0 EET} - {2910981600 10800 1 EEST} - {2929125600 7200 0 EET} - {2942431200 10800 1 EEST} - {2960575200 7200 0 EET} - {2973880800 10800 1 EEST} - {2992629600 7200 0 EET} - {3005330400 10800 1 EEST} - {3024079200 7200 0 EET} - {3036780000 10800 1 EEST} - {3055528800 7200 0 EET} - {3068834400 10800 1 EEST} - {3086978400 7200 0 EET} - {3100284000 10800 1 EEST} - {3118428000 7200 0 EET} - {3131733600 10800 1 EEST} - {3149877600 7200 0 EET} - {3163183200 10800 1 EEST} - {3181932000 7200 0 EET} - {3194632800 10800 1 EEST} - {3213381600 7200 0 EET} - {3226687200 10800 1 EEST} - {3244831200 7200 0 EET} - {3258136800 10800 1 EEST} - {3276280800 7200 0 EET} - {3289586400 10800 1 EEST} - {3307730400 7200 0 EET} - {3321036000 10800 1 EEST} - {3339180000 7200 0 EET} - {3352485600 10800 1 EEST} - {3371234400 7200 0 EET} - {3383935200 10800 1 EEST} - {3402684000 7200 0 EET} - {3415989600 10800 1 EEST} - {3434133600 7200 0 EET} - {3447439200 10800 1 EEST} - {3465583200 7200 0 EET} - {3478888800 10800 1 EEST} - {3497032800 7200 0 EET} - {3510338400 10800 1 EEST} - {3529087200 7200 0 EET} - {3541788000 10800 1 EEST} - {3560536800 7200 0 EET} - {3573237600 10800 1 EEST} - {3591986400 7200 0 EET} - {3605292000 10800 1 EEST} - {3623436000 7200 0 EET} - {3636741600 10800 1 EEST} - {3654885600 7200 0 EET} - {3668191200 10800 1 EEST} - {3686335200 7200 0 EET} - {3699640800 10800 1 EEST} - {3718389600 7200 0 EET} - {3731090400 10800 1 EEST} - {3749839200 7200 0 EET} - {3763144800 10800 1 EEST} - {3781288800 7200 0 EET} - {3794594400 10800 1 EEST} - {3812738400 7200 0 EET} - {3826044000 10800 1 EEST} - {3844188000 7200 0 EET} - {3857493600 10800 1 EEST} - {3876242400 7200 0 EET} - {3888943200 10800 1 EEST} - {3907692000 7200 0 EET} - {3920392800 10800 1 EEST} - {3939141600 7200 0 EET} - {3952447200 10800 1 EEST} - {3970591200 7200 0 EET} - {3983896800 10800 1 EEST} - {4002040800 7200 0 EET} - {4015346400 10800 1 EEST} - {4033490400 7200 0 EET} - {4046796000 10800 1 EEST} - {4065544800 7200 0 EET} - {4078245600 10800 1 EEST} - {4096994400 7200 0 EET} + {1351202400 10800 0 AST} } diff --git a/library/tzdata/Asia/Dili b/library/tzdata/Asia/Dili index 36910fd..f783557 100644 --- a/library/tzdata/Asia/Dili +++ b/library/tzdata/Asia/Dili @@ -5,6 +5,6 @@ set TZData(:Asia/Dili) { {-1830414140 28800 0 TLT} {-879152400 32400 0 JST} {-766054800 32400 0 TLT} - {199897200 28800 0 CIT} + {199897200 28800 0 WITA} {969120000 32400 0 TLT} } diff --git a/library/tzdata/Asia/Gaza b/library/tzdata/Asia/Gaza index a0636e2..7d62a96 100644 --- a/library/tzdata/Asia/Gaza +++ b/library/tzdata/Asia/Gaza @@ -102,177 +102,177 @@ set TZData(:Asia/Gaza) { {1333058400 10800 1 EEST} {1348178400 7200 0 EET} {1364508000 10800 1 EEST} - {1380232800 7200 0 EET} + {1380229200 7200 0 EET} {1395957600 10800 1 EEST} - {1411682400 7200 0 EET} + {1411678800 7200 0 EET} {1427407200 10800 1 EEST} - {1443132000 7200 0 EET} + {1443128400 7200 0 EET} {1459461600 10800 1 EEST} - {1474581600 7200 0 EET} + {1474578000 7200 0 EET} {1490911200 10800 1 EEST} - {1506031200 7200 0 EET} + {1506027600 7200 0 EET} {1522360800 10800 1 EEST} - {1537480800 7200 0 EET} + {1537477200 7200 0 EET} {1553810400 10800 1 EEST} - {1569535200 7200 0 EET} + {1569531600 7200 0 EET} {1585260000 10800 1 EEST} - {1600984800 7200 0 EET} + {1600981200 7200 0 EET} {1616709600 10800 1 EEST} - {1632434400 7200 0 EET} + {1632430800 7200 0 EET} {1648764000 10800 1 EEST} - {1663884000 7200 0 EET} + {1663880400 7200 0 EET} {1680213600 10800 1 EEST} - {1695333600 7200 0 EET} + {1695330000 7200 0 EET} {1711663200 10800 1 EEST} - {1727388000 7200 0 EET} + {1727384400 7200 0 EET} {1743112800 10800 1 EEST} - {1758837600 7200 0 EET} + {1758834000 7200 0 EET} {1774562400 10800 1 EEST} - {1790287200 7200 0 EET} + {1790283600 7200 0 EET} {1806012000 10800 1 EEST} - {1821736800 7200 0 EET} + {1821733200 7200 0 EET} {1838066400 10800 1 EEST} - {1853186400 7200 0 EET} + {1853182800 7200 0 EET} {1869516000 10800 1 EEST} - {1884636000 7200 0 EET} + {1884632400 7200 0 EET} {1900965600 10800 1 EEST} - {1916690400 7200 0 EET} + {1916686800 7200 0 EET} {1932415200 10800 1 EEST} - {1948140000 7200 0 EET} + {1948136400 7200 0 EET} {1963864800 10800 1 EEST} - {1979589600 7200 0 EET} + {1979586000 7200 0 EET} {1995919200 10800 1 EEST} - {2011039200 7200 0 EET} + {2011035600 7200 0 EET} {2027368800 10800 1 EEST} - {2042488800 7200 0 EET} + {2042485200 7200 0 EET} {2058818400 10800 1 EEST} - {2073938400 7200 0 EET} + {2073934800 7200 0 EET} {2090268000 10800 1 EEST} - {2105992800 7200 0 EET} + {2105989200 7200 0 EET} {2121717600 10800 1 EEST} - {2137442400 7200 0 EET} + {2137438800 7200 0 EET} {2153167200 10800 1 EEST} - {2168892000 7200 0 EET} + {2168888400 7200 0 EET} {2185221600 10800 1 EEST} - {2200341600 7200 0 EET} + {2200338000 7200 0 EET} {2216671200 10800 1 EEST} - {2231791200 7200 0 EET} + {2231787600 7200 0 EET} {2248120800 10800 1 EEST} - {2263845600 7200 0 EET} + {2263842000 7200 0 EET} {2279570400 10800 1 EEST} - {2295295200 7200 0 EET} + {2295291600 7200 0 EET} {2311020000 10800 1 EEST} - {2326744800 7200 0 EET} + {2326741200 7200 0 EET} {2343074400 10800 1 EEST} - {2358194400 7200 0 EET} + {2358190800 7200 0 EET} {2374524000 10800 1 EEST} - {2389644000 7200 0 EET} + {2389640400 7200 0 EET} {2405973600 10800 1 EEST} - {2421093600 7200 0 EET} + {2421090000 7200 0 EET} {2437423200 10800 1 EEST} - {2453148000 7200 0 EET} + {2453144400 7200 0 EET} {2468872800 10800 1 EEST} - {2484597600 7200 0 EET} + {2484594000 7200 0 EET} {2500322400 10800 1 EEST} - {2516047200 7200 0 EET} + {2516043600 7200 0 EET} {2532376800 10800 1 EEST} - {2547496800 7200 0 EET} + {2547493200 7200 0 EET} {2563826400 10800 1 EEST} - {2578946400 7200 0 EET} + {2578942800 7200 0 EET} {2595276000 10800 1 EEST} - {2611000800 7200 0 EET} + {2610997200 7200 0 EET} {2626725600 10800 1 EEST} - {2642450400 7200 0 EET} + {2642446800 7200 0 EET} {2658175200 10800 1 EEST} - {2673900000 7200 0 EET} + {2673896400 7200 0 EET} {2689624800 10800 1 EEST} - {2705349600 7200 0 EET} + {2705346000 7200 0 EET} {2721679200 10800 1 EEST} - {2736799200 7200 0 EET} + {2736795600 7200 0 EET} {2753128800 10800 1 EEST} - {2768248800 7200 0 EET} + {2768245200 7200 0 EET} {2784578400 10800 1 EEST} - {2800303200 7200 0 EET} + {2800299600 7200 0 EET} {2816028000 10800 1 EEST} - {2831752800 7200 0 EET} + {2831749200 7200 0 EET} {2847477600 10800 1 EEST} - {2863202400 7200 0 EET} + {2863198800 7200 0 EET} {2879532000 10800 1 EEST} - {2894652000 7200 0 EET} + {2894648400 7200 0 EET} {2910981600 10800 1 EEST} - {2926101600 7200 0 EET} + {2926098000 7200 0 EET} {2942431200 10800 1 EEST} - {2957551200 7200 0 EET} + {2957547600 7200 0 EET} {2973880800 10800 1 EEST} - {2989605600 7200 0 EET} + {2989602000 7200 0 EET} {3005330400 10800 1 EEST} - {3021055200 7200 0 EET} + {3021051600 7200 0 EET} {3036780000 10800 1 EEST} - {3052504800 7200 0 EET} + {3052501200 7200 0 EET} {3068834400 10800 1 EEST} - {3083954400 7200 0 EET} + {3083950800 7200 0 EET} {3100284000 10800 1 EEST} - {3115404000 7200 0 EET} + {3115400400 7200 0 EET} {3131733600 10800 1 EEST} - {3147458400 7200 0 EET} + {3147454800 7200 0 EET} {3163183200 10800 1 EEST} - {3178908000 7200 0 EET} + {3178904400 7200 0 EET} {3194632800 10800 1 EEST} - {3210357600 7200 0 EET} + {3210354000 7200 0 EET} {3226687200 10800 1 EEST} - {3241807200 7200 0 EET} + {3241803600 7200 0 EET} {3258136800 10800 1 EEST} - {3273256800 7200 0 EET} + {3273253200 7200 0 EET} {3289586400 10800 1 EEST} - {3304706400 7200 0 EET} + {3304702800 7200 0 EET} {3321036000 10800 1 EEST} - {3336760800 7200 0 EET} + {3336757200 7200 0 EET} {3352485600 10800 1 EEST} - {3368210400 7200 0 EET} + {3368206800 7200 0 EET} {3383935200 10800 1 EEST} - {3399660000 7200 0 EET} + {3399656400 7200 0 EET} {3415989600 10800 1 EEST} - {3431109600 7200 0 EET} + {3431106000 7200 0 EET} {3447439200 10800 1 EEST} - {3462559200 7200 0 EET} + {3462555600 7200 0 EET} {3478888800 10800 1 EEST} - {3494613600 7200 0 EET} + {3494610000 7200 0 EET} {3510338400 10800 1 EEST} - {3526063200 7200 0 EET} + {3526059600 7200 0 EET} {3541788000 10800 1 EEST} - {3557512800 7200 0 EET} + {3557509200 7200 0 EET} {3573237600 10800 1 EEST} - {3588962400 7200 0 EET} + {3588958800 7200 0 EET} {3605292000 10800 1 EEST} - {3620412000 7200 0 EET} + {3620408400 7200 0 EET} {3636741600 10800 1 EEST} - {3651861600 7200 0 EET} + {3651858000 7200 0 EET} {3668191200 10800 1 EEST} - {3683916000 7200 0 EET} + {3683912400 7200 0 EET} {3699640800 10800 1 EEST} - {3715365600 7200 0 EET} + {3715362000 7200 0 EET} {3731090400 10800 1 EEST} - {3746815200 7200 0 EET} + {3746811600 7200 0 EET} {3763144800 10800 1 EEST} - {3778264800 7200 0 EET} + {3778261200 7200 0 EET} {3794594400 10800 1 EEST} - {3809714400 7200 0 EET} + {3809710800 7200 0 EET} {3826044000 10800 1 EEST} - {3841164000 7200 0 EET} + {3841160400 7200 0 EET} {3857493600 10800 1 EEST} - {3873218400 7200 0 EET} + {3873214800 7200 0 EET} {3888943200 10800 1 EEST} - {3904668000 7200 0 EET} + {3904664400 7200 0 EET} {3920392800 10800 1 EEST} - {3936117600 7200 0 EET} + {3936114000 7200 0 EET} {3952447200 10800 1 EEST} - {3967567200 7200 0 EET} + {3967563600 7200 0 EET} {3983896800 10800 1 EEST} - {3999016800 7200 0 EET} + {3999013200 7200 0 EET} {4015346400 10800 1 EEST} - {4031071200 7200 0 EET} + {4031067600 7200 0 EET} {4046796000 10800 1 EEST} - {4062520800 7200 0 EET} + {4062517200 7200 0 EET} {4078245600 10800 1 EEST} - {4093970400 7200 0 EET} + {4093966800 7200 0 EET} } diff --git a/library/tzdata/Asia/Hebron b/library/tzdata/Asia/Hebron index a8a9019..1333d5a 100644 --- a/library/tzdata/Asia/Hebron +++ b/library/tzdata/Asia/Hebron @@ -101,177 +101,177 @@ set TZData(:Asia/Hebron) { {1333058400 10800 1 EEST} {1348178400 7200 0 EET} {1364508000 10800 1 EEST} - {1380232800 7200 0 EET} + {1380229200 7200 0 EET} {1395957600 10800 1 EEST} - {1411682400 7200 0 EET} + {1411678800 7200 0 EET} {1427407200 10800 1 EEST} - {1443132000 7200 0 EET} + {1443128400 7200 0 EET} {1459461600 10800 1 EEST} - {1474581600 7200 0 EET} + {1474578000 7200 0 EET} {1490911200 10800 1 EEST} - {1506031200 7200 0 EET} + {1506027600 7200 0 EET} {1522360800 10800 1 EEST} - {1537480800 7200 0 EET} + {1537477200 7200 0 EET} {1553810400 10800 1 EEST} - {1569535200 7200 0 EET} + {1569531600 7200 0 EET} {1585260000 10800 1 EEST} - {1600984800 7200 0 EET} + {1600981200 7200 0 EET} {1616709600 10800 1 EEST} - {1632434400 7200 0 EET} + {1632430800 7200 0 EET} {1648764000 10800 1 EEST} - {1663884000 7200 0 EET} + {1663880400 7200 0 EET} {1680213600 10800 1 EEST} - {1695333600 7200 0 EET} + {1695330000 7200 0 EET} {1711663200 10800 1 EEST} - {1727388000 7200 0 EET} + {1727384400 7200 0 EET} {1743112800 10800 1 EEST} - {1758837600 7200 0 EET} + {1758834000 7200 0 EET} {1774562400 10800 1 EEST} - {1790287200 7200 0 EET} + {1790283600 7200 0 EET} {1806012000 10800 1 EEST} - {1821736800 7200 0 EET} + {1821733200 7200 0 EET} {1838066400 10800 1 EEST} - {1853186400 7200 0 EET} + {1853182800 7200 0 EET} {1869516000 10800 1 EEST} - {1884636000 7200 0 EET} + {1884632400 7200 0 EET} {1900965600 10800 1 EEST} - {1916690400 7200 0 EET} + {1916686800 7200 0 EET} {1932415200 10800 1 EEST} - {1948140000 7200 0 EET} + {1948136400 7200 0 EET} {1963864800 10800 1 EEST} - {1979589600 7200 0 EET} + {1979586000 7200 0 EET} {1995919200 10800 1 EEST} - {2011039200 7200 0 EET} + {2011035600 7200 0 EET} {2027368800 10800 1 EEST} - {2042488800 7200 0 EET} + {2042485200 7200 0 EET} {2058818400 10800 1 EEST} - {2073938400 7200 0 EET} + {2073934800 7200 0 EET} {2090268000 10800 1 EEST} - {2105992800 7200 0 EET} + {2105989200 7200 0 EET} {2121717600 10800 1 EEST} - {2137442400 7200 0 EET} + {2137438800 7200 0 EET} {2153167200 10800 1 EEST} - {2168892000 7200 0 EET} + {2168888400 7200 0 EET} {2185221600 10800 1 EEST} - {2200341600 7200 0 EET} + {2200338000 7200 0 EET} {2216671200 10800 1 EEST} - {2231791200 7200 0 EET} + {2231787600 7200 0 EET} {2248120800 10800 1 EEST} - {2263845600 7200 0 EET} + {2263842000 7200 0 EET} {2279570400 10800 1 EEST} - {2295295200 7200 0 EET} + {2295291600 7200 0 EET} {2311020000 10800 1 EEST} - {2326744800 7200 0 EET} + {2326741200 7200 0 EET} {2343074400 10800 1 EEST} - {2358194400 7200 0 EET} + {2358190800 7200 0 EET} {2374524000 10800 1 EEST} - {2389644000 7200 0 EET} + {2389640400 7200 0 EET} {2405973600 10800 1 EEST} - {2421093600 7200 0 EET} + {2421090000 7200 0 EET} {2437423200 10800 1 EEST} - {2453148000 7200 0 EET} + {2453144400 7200 0 EET} {2468872800 10800 1 EEST} - {2484597600 7200 0 EET} + {2484594000 7200 0 EET} {2500322400 10800 1 EEST} - {2516047200 7200 0 EET} + {2516043600 7200 0 EET} {2532376800 10800 1 EEST} - {2547496800 7200 0 EET} + {2547493200 7200 0 EET} {2563826400 10800 1 EEST} - {2578946400 7200 0 EET} + {2578942800 7200 0 EET} {2595276000 10800 1 EEST} - {2611000800 7200 0 EET} + {2610997200 7200 0 EET} {2626725600 10800 1 EEST} - {2642450400 7200 0 EET} + {2642446800 7200 0 EET} {2658175200 10800 1 EEST} - {2673900000 7200 0 EET} + {2673896400 7200 0 EET} {2689624800 10800 1 EEST} - {2705349600 7200 0 EET} + {2705346000 7200 0 EET} {2721679200 10800 1 EEST} - {2736799200 7200 0 EET} + {2736795600 7200 0 EET} {2753128800 10800 1 EEST} - {2768248800 7200 0 EET} + {2768245200 7200 0 EET} {2784578400 10800 1 EEST} - {2800303200 7200 0 EET} + {2800299600 7200 0 EET} {2816028000 10800 1 EEST} - {2831752800 7200 0 EET} + {2831749200 7200 0 EET} {2847477600 10800 1 EEST} - {2863202400 7200 0 EET} + {2863198800 7200 0 EET} {2879532000 10800 1 EEST} - {2894652000 7200 0 EET} + {2894648400 7200 0 EET} {2910981600 10800 1 EEST} - {2926101600 7200 0 EET} + {2926098000 7200 0 EET} {2942431200 10800 1 EEST} - {2957551200 7200 0 EET} + {2957547600 7200 0 EET} {2973880800 10800 1 EEST} - {2989605600 7200 0 EET} + {2989602000 7200 0 EET} {3005330400 10800 1 EEST} - {3021055200 7200 0 EET} + {3021051600 7200 0 EET} {3036780000 10800 1 EEST} - {3052504800 7200 0 EET} + {3052501200 7200 0 EET} {3068834400 10800 1 EEST} - {3083954400 7200 0 EET} + {3083950800 7200 0 EET} {3100284000 10800 1 EEST} - {3115404000 7200 0 EET} + {3115400400 7200 0 EET} {3131733600 10800 1 EEST} - {3147458400 7200 0 EET} + {3147454800 7200 0 EET} {3163183200 10800 1 EEST} - {3178908000 7200 0 EET} + {3178904400 7200 0 EET} {3194632800 10800 1 EEST} - {3210357600 7200 0 EET} + {3210354000 7200 0 EET} {3226687200 10800 1 EEST} - {3241807200 7200 0 EET} + {3241803600 7200 0 EET} {3258136800 10800 1 EEST} - {3273256800 7200 0 EET} + {3273253200 7200 0 EET} {3289586400 10800 1 EEST} - {3304706400 7200 0 EET} + {3304702800 7200 0 EET} {3321036000 10800 1 EEST} - {3336760800 7200 0 EET} + {3336757200 7200 0 EET} {3352485600 10800 1 EEST} - {3368210400 7200 0 EET} + {3368206800 7200 0 EET} {3383935200 10800 1 EEST} - {3399660000 7200 0 EET} + {3399656400 7200 0 EET} {3415989600 10800 1 EEST} - {3431109600 7200 0 EET} + {3431106000 7200 0 EET} {3447439200 10800 1 EEST} - {3462559200 7200 0 EET} + {3462555600 7200 0 EET} {3478888800 10800 1 EEST} - {3494613600 7200 0 EET} + {3494610000 7200 0 EET} {3510338400 10800 1 EEST} - {3526063200 7200 0 EET} + {3526059600 7200 0 EET} {3541788000 10800 1 EEST} - {3557512800 7200 0 EET} + {3557509200 7200 0 EET} {3573237600 10800 1 EEST} - {3588962400 7200 0 EET} + {3588958800 7200 0 EET} {3605292000 10800 1 EEST} - {3620412000 7200 0 EET} + {3620408400 7200 0 EET} {3636741600 10800 1 EEST} - {3651861600 7200 0 EET} + {3651858000 7200 0 EET} {3668191200 10800 1 EEST} - {3683916000 7200 0 EET} + {3683912400 7200 0 EET} {3699640800 10800 1 EEST} - {3715365600 7200 0 EET} + {3715362000 7200 0 EET} {3731090400 10800 1 EEST} - {3746815200 7200 0 EET} + {3746811600 7200 0 EET} {3763144800 10800 1 EEST} - {3778264800 7200 0 EET} + {3778261200 7200 0 EET} {3794594400 10800 1 EEST} - {3809714400 7200 0 EET} + {3809710800 7200 0 EET} {3826044000 10800 1 EEST} - {3841164000 7200 0 EET} + {3841160400 7200 0 EET} {3857493600 10800 1 EEST} - {3873218400 7200 0 EET} + {3873214800 7200 0 EET} {3888943200 10800 1 EEST} - {3904668000 7200 0 EET} + {3904664400 7200 0 EET} {3920392800 10800 1 EEST} - {3936117600 7200 0 EET} + {3936114000 7200 0 EET} {3952447200 10800 1 EEST} - {3967567200 7200 0 EET} + {3967563600 7200 0 EET} {3983896800 10800 1 EEST} - {3999016800 7200 0 EET} + {3999013200 7200 0 EET} {4015346400 10800 1 EEST} - {4031071200 7200 0 EET} + {4031067600 7200 0 EET} {4046796000 10800 1 EEST} - {4062520800 7200 0 EET} + {4062517200 7200 0 EET} {4078245600 10800 1 EEST} - {4093970400 7200 0 EET} + {4093966800 7200 0 EET} } diff --git a/library/tzdata/Asia/Jakarta b/library/tzdata/Asia/Jakarta index 27033e8..75cd659 100644 --- a/library/tzdata/Asia/Jakarta +++ b/library/tzdata/Asia/Jakarta @@ -2,12 +2,12 @@ set TZData(:Asia/Jakarta) { {-9223372036854775808 25632 0 LMT} - {-3231299232 25632 0 JMT} + {-3231299232 25632 0 BMT} {-1451719200 26400 0 JAVT} - {-1172906400 27000 0 WIT} + {-1172906400 27000 0 WIB} {-876641400 32400 0 JST} - {-766054800 27000 0 WIT} - {-683883000 28800 0 WIT} - {-620812800 27000 0 WIT} - {-189415800 25200 0 WIT} + {-766054800 27000 0 WIB} + {-683883000 28800 0 WIB} + {-620812800 27000 0 WIB} + {-189415800 25200 0 WIB} } diff --git a/library/tzdata/Asia/Jayapura b/library/tzdata/Asia/Jayapura index 893da8b..a71228f 100644 --- a/library/tzdata/Asia/Jayapura +++ b/library/tzdata/Asia/Jayapura @@ -2,7 +2,7 @@ set TZData(:Asia/Jayapura) { {-9223372036854775808 33768 0 LMT} - {-1172913768 32400 0 EIT} + {-1172913768 32400 0 WIT} {-799491600 34200 0 CST} - {-189423000 32400 0 EIT} + {-189423000 32400 0 WIT} } diff --git a/library/tzdata/Asia/Makassar b/library/tzdata/Asia/Makassar index aa604b4..be947f3 100644 --- a/library/tzdata/Asia/Makassar +++ b/library/tzdata/Asia/Makassar @@ -3,7 +3,7 @@ set TZData(:Asia/Makassar) { {-9223372036854775808 28656 0 LMT} {-1577951856 28656 0 MMT} - {-1172908656 28800 0 CIT} + {-1172908656 28800 0 WITA} {-880272000 32400 0 JST} - {-766054800 28800 0 CIT} + {-766054800 28800 0 WITA} } diff --git a/library/tzdata/Asia/Pontianak b/library/tzdata/Asia/Pontianak index f3567dd..728b552 100644 --- a/library/tzdata/Asia/Pontianak +++ b/library/tzdata/Asia/Pontianak @@ -3,11 +3,11 @@ set TZData(:Asia/Pontianak) { {-9223372036854775808 26240 0 LMT} {-1946186240 26240 0 PMT} - {-1172906240 27000 0 WIT} + {-1172906240 27000 0 WIB} {-881220600 32400 0 JST} - {-766054800 27000 0 WIT} - {-683883000 28800 0 WIT} - {-620812800 27000 0 WIT} - {-189415800 28800 0 CIT} - {567964800 25200 0 WIT} + {-766054800 27000 0 WIB} + {-683883000 28800 0 WIB} + {-620812800 27000 0 WIB} + {-189415800 28800 0 WITA} + {567964800 25200 0 WIB} } diff --git a/library/tzdata/Europe/Vaduz b/library/tzdata/Europe/Vaduz index 3118331..095e018 100644 --- a/library/tzdata/Europe/Vaduz +++ b/library/tzdata/Europe/Vaduz @@ -1,245 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Vaduz) { - {-9223372036854775808 2284 0 LMT} - {-2385247084 3600 0 CET} - {347151600 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} - {449024400 7200 1 CEST} - {465354000 3600 0 CET} - {481078800 7200 1 CEST} - {496803600 3600 0 CET} - {512528400 7200 1 CEST} - {528253200 3600 0 CET} - {543978000 7200 1 CEST} - {559702800 3600 0 CET} - {575427600 7200 1 CEST} - {591152400 3600 0 CET} - {606877200 7200 1 CEST} - {622602000 3600 0 CET} - {638326800 7200 1 CEST} - {654656400 3600 0 CET} - {670381200 7200 1 CEST} - {686106000 3600 0 CET} - {701830800 7200 1 CEST} - {717555600 3600 0 CET} - {733280400 7200 1 CEST} - {749005200 3600 0 CET} - {764730000 7200 1 CEST} - {780454800 3600 0 CET} - {796179600 7200 1 CEST} - {811904400 3600 0 CET} - {828234000 7200 1 CEST} - {846378000 3600 0 CET} - {859683600 7200 1 CEST} - {877827600 3600 0 CET} - {891133200 7200 1 CEST} - {909277200 3600 0 CET} - {922582800 7200 1 CEST} - {941331600 3600 0 CET} - {954032400 7200 1 CEST} - {972781200 3600 0 CET} - {985482000 7200 1 CEST} - {1004230800 3600 0 CET} - {1017536400 7200 1 CEST} - {1035680400 3600 0 CET} - {1048986000 7200 1 CEST} - {1067130000 3600 0 CET} - {1080435600 7200 1 CEST} - {1099184400 3600 0 CET} - {1111885200 7200 1 CEST} - {1130634000 3600 0 CET} - {1143334800 7200 1 CEST} - {1162083600 3600 0 CET} - {1174784400 7200 1 CEST} - {1193533200 3600 0 CET} - {1206838800 7200 1 CEST} - {1224982800 3600 0 CET} - {1238288400 7200 1 CEST} - {1256432400 3600 0 CET} - {1269738000 7200 1 CEST} - {1288486800 3600 0 CET} - {1301187600 7200 1 CEST} - {1319936400 3600 0 CET} - {1332637200 7200 1 CEST} - {1351386000 3600 0 CET} - {1364691600 7200 1 CEST} - {1382835600 3600 0 CET} - {1396141200 7200 1 CEST} - {1414285200 3600 0 CET} - {1427590800 7200 1 CEST} - {1445734800 3600 0 CET} - {1459040400 7200 1 CEST} - {1477789200 3600 0 CET} - {1490490000 7200 1 CEST} - {1509238800 3600 0 CET} - {1521939600 7200 1 CEST} - {1540688400 3600 0 CET} - {1553994000 7200 1 CEST} - {1572138000 3600 0 CET} - {1585443600 7200 1 CEST} - {1603587600 3600 0 CET} - {1616893200 7200 1 CEST} - {1635642000 3600 0 CET} - {1648342800 7200 1 CEST} - {1667091600 3600 0 CET} - {1679792400 7200 1 CEST} - {1698541200 3600 0 CET} - {1711846800 7200 1 CEST} - {1729990800 3600 0 CET} - {1743296400 7200 1 CEST} - {1761440400 3600 0 CET} - {1774746000 7200 1 CEST} - {1792890000 3600 0 CET} - {1806195600 7200 1 CEST} - {1824944400 3600 0 CET} - {1837645200 7200 1 CEST} - {1856394000 3600 0 CET} - {1869094800 7200 1 CEST} - {1887843600 3600 0 CET} - {1901149200 7200 1 CEST} - {1919293200 3600 0 CET} - {1932598800 7200 1 CEST} - {1950742800 3600 0 CET} - {1964048400 7200 1 CEST} - {1982797200 3600 0 CET} - {1995498000 7200 1 CEST} - {2014246800 3600 0 CET} - {2026947600 7200 1 CEST} - {2045696400 3600 0 CET} - {2058397200 7200 1 CEST} - {2077146000 3600 0 CET} - {2090451600 7200 1 CEST} - {2108595600 3600 0 CET} - {2121901200 7200 1 CEST} - {2140045200 3600 0 CET} - {2153350800 7200 1 CEST} - {2172099600 3600 0 CET} - {2184800400 7200 1 CEST} - {2203549200 3600 0 CET} - {2216250000 7200 1 CEST} - {2234998800 3600 0 CET} - {2248304400 7200 1 CEST} - {2266448400 3600 0 CET} - {2279754000 7200 1 CEST} - {2297898000 3600 0 CET} - {2311203600 7200 1 CEST} - {2329347600 3600 0 CET} - {2342653200 7200 1 CEST} - {2361402000 3600 0 CET} - {2374102800 7200 1 CEST} - {2392851600 3600 0 CET} - {2405552400 7200 1 CEST} - {2424301200 3600 0 CET} - {2437606800 7200 1 CEST} - {2455750800 3600 0 CET} - {2469056400 7200 1 CEST} - {2487200400 3600 0 CET} - {2500506000 7200 1 CEST} - {2519254800 3600 0 CET} - {2531955600 7200 1 CEST} - {2550704400 3600 0 CET} - {2563405200 7200 1 CEST} - {2582154000 3600 0 CET} - {2595459600 7200 1 CEST} - {2613603600 3600 0 CET} - {2626909200 7200 1 CEST} - {2645053200 3600 0 CET} - {2658358800 7200 1 CEST} - {2676502800 3600 0 CET} - {2689808400 7200 1 CEST} - {2708557200 3600 0 CET} - {2721258000 7200 1 CEST} - {2740006800 3600 0 CET} - {2752707600 7200 1 CEST} - {2771456400 3600 0 CET} - {2784762000 7200 1 CEST} - {2802906000 3600 0 CET} - {2816211600 7200 1 CEST} - {2834355600 3600 0 CET} - {2847661200 7200 1 CEST} - {2866410000 3600 0 CET} - {2879110800 7200 1 CEST} - {2897859600 3600 0 CET} - {2910560400 7200 1 CEST} - {2929309200 3600 0 CET} - {2942010000 7200 1 CEST} - {2960758800 3600 0 CET} - {2974064400 7200 1 CEST} - {2992208400 3600 0 CET} - {3005514000 7200 1 CEST} - {3023658000 3600 0 CET} - {3036963600 7200 1 CEST} - {3055712400 3600 0 CET} - {3068413200 7200 1 CEST} - {3087162000 3600 0 CET} - {3099862800 7200 1 CEST} - {3118611600 3600 0 CET} - {3131917200 7200 1 CEST} - {3150061200 3600 0 CET} - {3163366800 7200 1 CEST} - {3181510800 3600 0 CET} - {3194816400 7200 1 CEST} - {3212960400 3600 0 CET} - {3226266000 7200 1 CEST} - {3245014800 3600 0 CET} - {3257715600 7200 1 CEST} - {3276464400 3600 0 CET} - {3289165200 7200 1 CEST} - {3307914000 3600 0 CET} - {3321219600 7200 1 CEST} - {3339363600 3600 0 CET} - {3352669200 7200 1 CEST} - {3370813200 3600 0 CET} - {3384118800 7200 1 CEST} - {3402867600 3600 0 CET} - {3415568400 7200 1 CEST} - {3434317200 3600 0 CET} - {3447018000 7200 1 CEST} - {3465766800 3600 0 CET} - {3479072400 7200 1 CEST} - {3497216400 3600 0 CET} - {3510522000 7200 1 CEST} - {3528666000 3600 0 CET} - {3541971600 7200 1 CEST} - {3560115600 3600 0 CET} - {3573421200 7200 1 CEST} - {3592170000 3600 0 CET} - {3604870800 7200 1 CEST} - {3623619600 3600 0 CET} - {3636320400 7200 1 CEST} - {3655069200 3600 0 CET} - {3668374800 7200 1 CEST} - {3686518800 3600 0 CET} - {3699824400 7200 1 CEST} - {3717968400 3600 0 CET} - {3731274000 7200 1 CEST} - {3750022800 3600 0 CET} - {3762723600 7200 1 CEST} - {3781472400 3600 0 CET} - {3794173200 7200 1 CEST} - {3812922000 3600 0 CET} - {3825622800 7200 1 CEST} - {3844371600 3600 0 CET} - {3857677200 7200 1 CEST} - {3875821200 3600 0 CET} - {3889126800 7200 1 CEST} - {3907270800 3600 0 CET} - {3920576400 7200 1 CEST} - {3939325200 3600 0 CET} - {3952026000 7200 1 CEST} - {3970774800 3600 0 CET} - {3983475600 7200 1 CEST} - {4002224400 3600 0 CET} - {4015530000 7200 1 CEST} - {4033674000 3600 0 CET} - {4046979600 7200 1 CEST} - {4065123600 3600 0 CET} - {4078429200 7200 1 CEST} - {4096573200 3600 0 CET} +if {![info exists TZData(Europe/Zurich)]} { + LoadTimeZoneFile Europe/Zurich } +set TZData(:Europe/Vaduz) $TZData(:Europe/Zurich) diff --git a/library/tzdata/Europe/Zurich b/library/tzdata/Europe/Zurich index 33831c3..87a20db 100644 --- a/library/tzdata/Europe/Zurich +++ b/library/tzdata/Europe/Zurich @@ -2,8 +2,8 @@ set TZData(:Europe/Zurich) { {-9223372036854775808 2048 0 LMT} - {-3827954048 1784 0 BMT} - {-2385246584 3600 0 CET} + {-3675198848 1786 0 BMT} + {-2385246586 3600 0 CET} {-904435200 7200 1 CEST} {-891129600 3600 0 CET} {-872985600 7200 1 CEST} diff --git a/library/tzdata/Pacific/Fiji b/library/tzdata/Pacific/Fiji index bfcaa03..454ee87 100644 --- a/library/tzdata/Pacific/Fiji +++ b/library/tzdata/Pacific/Fiji @@ -15,11 +15,11 @@ set TZData(:Pacific/Fiji) { {1327154400 43200 0 FJT} {1350741600 46800 1 FJST} {1358604000 43200 0 FJT} - {1382191200 46800 1 FJST} + {1382796000 46800 1 FJST} {1390053600 43200 0 FJT} - {1413640800 46800 1 FJST} + {1414245600 46800 1 FJST} {1421503200 43200 0 FJT} - {1445090400 46800 1 FJST} + {1445695200 46800 1 FJST} {1453557600 43200 0 FJT} {1477144800 46800 1 FJST} {1485007200 43200 0 FJT} @@ -27,9 +27,9 @@ set TZData(:Pacific/Fiji) { {1516456800 43200 0 FJT} {1540044000 46800 1 FJST} {1547906400 43200 0 FJT} - {1571493600 46800 1 FJST} + {1572098400 46800 1 FJST} {1579356000 43200 0 FJT} - {1602943200 46800 1 FJST} + {1603548000 46800 1 FJST} {1611410400 43200 0 FJT} {1634997600 46800 1 FJST} {1642860000 43200 0 FJT} @@ -37,11 +37,11 @@ set TZData(:Pacific/Fiji) { {1674309600 43200 0 FJT} {1697896800 46800 1 FJST} {1705759200 43200 0 FJT} - {1729346400 46800 1 FJST} + {1729951200 46800 1 FJST} {1737208800 43200 0 FJT} - {1760796000 46800 1 FJST} + {1761400800 46800 1 FJST} {1768658400 43200 0 FJT} - {1792245600 46800 1 FJST} + {1792850400 46800 1 FJST} {1800712800 43200 0 FJT} {1824300000 46800 1 FJST} {1832162400 43200 0 FJT} @@ -49,9 +49,9 @@ set TZData(:Pacific/Fiji) { {1863612000 43200 0 FJT} {1887199200 46800 1 FJST} {1895061600 43200 0 FJT} - {1918648800 46800 1 FJST} + {1919253600 46800 1 FJST} {1926511200 43200 0 FJT} - {1950098400 46800 1 FJST} + {1950703200 46800 1 FJST} {1957960800 43200 0 FJT} {1982152800 46800 1 FJST} {1990015200 43200 0 FJT} @@ -61,9 +61,9 @@ set TZData(:Pacific/Fiji) { {2052914400 43200 0 FJT} {2076501600 46800 1 FJST} {2084364000 43200 0 FJT} - {2107951200 46800 1 FJST} + {2108556000 46800 1 FJST} {2115813600 43200 0 FJT} - {2139400800 46800 1 FJST} + {2140005600 46800 1 FJST} {2147868000 43200 0 FJT} {2171455200 46800 1 FJST} {2179317600 43200 0 FJT} @@ -71,11 +71,11 @@ set TZData(:Pacific/Fiji) { {2210767200 43200 0 FJT} {2234354400 46800 1 FJST} {2242216800 43200 0 FJT} - {2265804000 46800 1 FJST} + {2266408800 46800 1 FJST} {2273666400 43200 0 FJT} - {2297253600 46800 1 FJST} + {2297858400 46800 1 FJST} {2305116000 43200 0 FJT} - {2328703200 46800 1 FJST} + {2329308000 46800 1 FJST} {2337170400 43200 0 FJT} {2360757600 46800 1 FJST} {2368620000 43200 0 FJT} @@ -83,9 +83,9 @@ set TZData(:Pacific/Fiji) { {2400069600 43200 0 FJT} {2423656800 46800 1 FJST} {2431519200 43200 0 FJT} - {2455106400 46800 1 FJST} + {2455711200 46800 1 FJST} {2462968800 43200 0 FJT} - {2486556000 46800 1 FJST} + {2487160800 46800 1 FJST} {2495023200 43200 0 FJT} {2518610400 46800 1 FJST} {2526472800 43200 0 FJT} @@ -93,11 +93,11 @@ set TZData(:Pacific/Fiji) { {2557922400 43200 0 FJT} {2581509600 46800 1 FJST} {2589372000 43200 0 FJT} - {2612959200 46800 1 FJST} + {2613564000 46800 1 FJST} {2620821600 43200 0 FJT} - {2644408800 46800 1 FJST} + {2645013600 46800 1 FJST} {2652271200 43200 0 FJT} - {2675858400 46800 1 FJST} + {2676463200 46800 1 FJST} {2684325600 43200 0 FJT} {2707912800 46800 1 FJST} {2715775200 43200 0 FJT} @@ -105,9 +105,9 @@ set TZData(:Pacific/Fiji) { {2747224800 43200 0 FJT} {2770812000 46800 1 FJST} {2778674400 43200 0 FJT} - {2802261600 46800 1 FJST} + {2802866400 46800 1 FJST} {2810124000 43200 0 FJT} - {2833711200 46800 1 FJST} + {2834316000 46800 1 FJST} {2841573600 43200 0 FJT} {2865765600 46800 1 FJST} {2873628000 43200 0 FJT} @@ -117,9 +117,9 @@ set TZData(:Pacific/Fiji) { {2936527200 43200 0 FJT} {2960114400 46800 1 FJST} {2967976800 43200 0 FJT} - {2991564000 46800 1 FJST} + {2992168800 46800 1 FJST} {2999426400 43200 0 FJT} - {3023013600 46800 1 FJST} + {3023618400 46800 1 FJST} {3031480800 43200 0 FJT} {3055068000 46800 1 FJST} {3062930400 43200 0 FJT} @@ -127,11 +127,11 @@ set TZData(:Pacific/Fiji) { {3094380000 43200 0 FJT} {3117967200 46800 1 FJST} {3125829600 43200 0 FJT} - {3149416800 46800 1 FJST} + {3150021600 46800 1 FJST} {3157279200 43200 0 FJT} - {3180866400 46800 1 FJST} + {3181471200 46800 1 FJST} {3188728800 43200 0 FJT} - {3212316000 46800 1 FJST} + {3212920800 46800 1 FJST} {3220783200 43200 0 FJT} {3244370400 46800 1 FJST} {3252232800 43200 0 FJT} @@ -139,9 +139,9 @@ set TZData(:Pacific/Fiji) { {3283682400 43200 0 FJT} {3307269600 46800 1 FJST} {3315132000 43200 0 FJT} - {3338719200 46800 1 FJST} + {3339324000 46800 1 FJST} {3346581600 43200 0 FJT} - {3370168800 46800 1 FJST} + {3370773600 46800 1 FJST} {3378636000 43200 0 FJT} {3402223200 46800 1 FJST} {3410085600 43200 0 FJT} @@ -149,11 +149,11 @@ set TZData(:Pacific/Fiji) { {3441535200 43200 0 FJT} {3465122400 46800 1 FJST} {3472984800 43200 0 FJT} - {3496572000 46800 1 FJST} + {3497176800 46800 1 FJST} {3504434400 43200 0 FJT} - {3528021600 46800 1 FJST} + {3528626400 46800 1 FJST} {3535884000 43200 0 FJT} - {3559471200 46800 1 FJST} + {3560076000 46800 1 FJST} {3567938400 43200 0 FJT} {3591525600 46800 1 FJST} {3599388000 43200 0 FJT} @@ -161,9 +161,9 @@ set TZData(:Pacific/Fiji) { {3630837600 43200 0 FJT} {3654424800 46800 1 FJST} {3662287200 43200 0 FJT} - {3685874400 46800 1 FJST} + {3686479200 46800 1 FJST} {3693736800 43200 0 FJT} - {3717324000 46800 1 FJST} + {3717928800 46800 1 FJST} {3725186400 43200 0 FJT} {3749378400 46800 1 FJST} {3757240800 43200 0 FJT} @@ -173,9 +173,9 @@ set TZData(:Pacific/Fiji) { {3820140000 43200 0 FJT} {3843727200 46800 1 FJST} {3851589600 43200 0 FJT} - {3875176800 46800 1 FJST} + {3875781600 46800 1 FJST} {3883039200 43200 0 FJT} - {3906626400 46800 1 FJST} + {3907231200 46800 1 FJST} {3915093600 43200 0 FJT} {3938680800 46800 1 FJST} {3946543200 43200 0 FJT} @@ -183,9 +183,9 @@ set TZData(:Pacific/Fiji) { {3977992800 43200 0 FJT} {4001580000 46800 1 FJST} {4009442400 43200 0 FJT} - {4033029600 46800 1 FJST} + {4033634400 46800 1 FJST} {4040892000 43200 0 FJT} - {4064479200 46800 1 FJST} + {4065084000 46800 1 FJST} {4072341600 43200 0 FJT} - {4095928800 46800 1 FJST} + {4096533600 46800 1 FJST} } diff --git a/library/tzdata/Pacific/Johnston b/library/tzdata/Pacific/Johnston index 7f9fee4..21ab39a 100644 --- a/library/tzdata/Pacific/Johnston +++ b/library/tzdata/Pacific/Johnston @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Johnston) { - {-9223372036854775808 -36000 0 HST} +if {![info exists TZData(Pacific/Honolulu)]} { + LoadTimeZoneFile Pacific/Honolulu } +set TZData(:Pacific/Johnston) $TZData(:Pacific/Honolulu) -- cgit v0.12 From ed5a6c598b93838fa631c454cc0bb1af031d3c88 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 b64a70d3402ce6bbee1a32e8bb48e16144f3744d Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 6 Oct 2013 19:17:20 +0000 Subject: [3381085] Improved way of detecting what version of the documentation to build. Set the HTML_VERSION environment variable to override the (sensible) default. --- unix/Makefile.in | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 505f7e0..74dd150 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -2076,6 +2076,9 @@ alldist: dist # build of this HTML documentation that has already been placed online. As # such, this rule is not guaranteed to work well on all systems; it only needs # to function on those of the Tcl/Tk maintainers. +# +# Also note that the 8.6 tool build requires an installed 8.6 native Tcl +# interpreter in order to be able to run. #-------------------------------------------------------------------------- html: ${NATIVE_TCLSH} @@ -2088,9 +2091,12 @@ html-tk: ${NATIVE_TCLSH} $(BUILD_HTML) --tk @EXTRA_BUILD_HTML@ +# You'd better have these programs or you will have problems creating Makefile +# from Makefile.in in the first place... +HTML_VERSION = `basename $(TOP_DIR) | sed s/tcl//` BUILD_HTML = \ @${NATIVE_TCLSH} $(TOOL_DIR)/tcltk-man2html.tcl \ - --htmldir="$(HTML_INSTALL_DIR)" \ + --useversion=$(HTML_VERSION) --htmldir="$(HTML_INSTALL_DIR)" \ --srcdir=$(TOP_DIR)/.. $(BUILD_HTML_FLAGS) #-------------------------------------------------------------------------- -- cgit v0.12 From 4e6df409a8a45c4356447e304a5300a6324c3c09 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Oct 2013 19:27:50 +0000 Subject: First attempt to fix bug [d4e464ae48]: tcl 8.5.15/8.61 breaks python make check on darwin --- unix/tclUnixNotfy.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index ec721ca..f41ef68 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -202,7 +202,7 @@ static Tcl_ThreadId notifierThread; #ifdef TCL_THREADS static void NotifierThreadProc(ClientData clientData); -#ifdef HAVE_PTHREAD_ATFORK +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) static int atForkInit = 0; static void AtForkPrepare(void); static void AtForkParent(void); @@ -282,7 +282,7 @@ Tcl_InitNotifier(void) */ Tcl_MutexLock(¬ifierMutex); -#ifdef HAVE_PTHREAD_ATFORK +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) /* * Install pthread_atfork handlers to reinitialize the notifier in the * child of a fork. @@ -296,7 +296,7 @@ Tcl_InitNotifier(void) } atForkInit = 1; } -#endif +#endif /* HAVE_PTHREAD_ATFORK */ /* * Check if my process id changed, e.g. I was forked * In this case, restart the notifier thread and close the @@ -1273,7 +1273,7 @@ NotifierThreadProc( TclpThreadExit (0); } -#ifdef HAVE_PTHREAD_ATFORK +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) /* *---------------------------------------------------------------------- * -- cgit v0.12 From 784987f7c11d9990ed7e2db04d85d42f177bdefd Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 8 Oct 2013 09:02:50 +0000 Subject: Working towards better handling of stack balance with break and continue exceptions. --- generic/tclAssembly.c | 1 + generic/tclCompCmds.c | 4 +- generic/tclCompCmdsSZ.c | 4 +- generic/tclCompExpr.c | 4 +- generic/tclCompile.c | 150 +++++++++++++++++++++++++++++++++++++++++++++++- generic/tclCompile.h | 1 + generic/tclEnsemble.c | 4 +- 7 files changed, 156 insertions(+), 12 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 946c729..08da075 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1450,6 +1450,7 @@ AssembleOneLine( goto cleanup; } + // FIXME - use TclEmitInvoke BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); break; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7e6b6da..942d74c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -269,7 +269,7 @@ TclCompileArraySetCmd( if (isDataValid && !isDataEven) { PushStringLiteral(envPtr, "list must have an even number of elements"); PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); + TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); goto done; } @@ -354,7 +354,7 @@ TclCompileArraySetCmd( TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); PushStringLiteral(envPtr, "list must have an even number of elements"); PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); + TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); TclAdjustStackDepth(-1, envPtr); fwd = CurrentOffset(envPtr) - offsetFwd; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 44cb66e..a5ec731 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1965,7 +1965,7 @@ TclCompileThrowCmd( OP( LIST_LENGTH); OP1( JUMP_FALSE1, 16); OP4( LIST, 2); - OP44( RETURN_IMM, 1, 0); + OP44( RETURN_IMM, TCL_ERROR, 0); TclAdjustStackDepth(2, envPtr); OP( POP); OP( POP); @@ -1974,7 +1974,7 @@ TclCompileThrowCmd( PUSH( "type must be non-empty list"); PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}"); } - OP44( RETURN_IMM, 1, 0); + OP44( RETURN_IMM, TCL_ERROR, 0); return TCL_OK; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index d8e4d9f..94c1bd6 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2335,9 +2335,9 @@ CompileExprTree( */ if (numWords < 255) { - TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK1, numWords); } else { - TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords); } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d15ef3a..a5b0bd8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1738,9 +1738,9 @@ TclCompileInvocation( } if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx); } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); } } @@ -1802,7 +1802,7 @@ CompileExpanded( * stack-neutral in general. */ - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED); envPtr->expandCount--; TclAdjustStackDepth(1 - wordIdx, envPtr); } @@ -3901,6 +3901,150 @@ TclFixupForwardJump( return 1; /* the jump was grown */ } +void +TclEmitInvoke( + CompileEnv *envPtr, + int opcode, + ...) +{ + va_list argList; + ExceptionRange *rangePtr; + ExceptionAux *auxBreakPtr, *auxContinuePtr; + int arg1, arg2, wordCount = 0, loopRange, predictedDepth; + + /* + * Parse the arguments. + */ + + va_start(argList, opcode); + switch (opcode) { + case INST_INVOKE_STK1: + wordCount = arg1 = va_arg(argList, int); + arg2 = 0; + break; + case INST_INVOKE_STK4: + wordCount = arg1 = 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; + break; + default: + Tcl_Panic("unexpected opcode"); + case INST_INVOKE_EXPANDED: + wordCount = arg1 = arg2 = 0; + break; + } + va_end(argList); + + /* + * Determine if we need to handle break and continue exceptions with a + * special handling exception range (so that we can correctly unwind the + * stack). + */ + + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr); + if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { + auxBreakPtr = NULL; + } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount + && auxBreakPtr->expandTarget == envPtr->expandCount) { + auxBreakPtr = NULL; + } + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, + &auxContinuePtr); + if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { + auxContinuePtr = NULL; + } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount + && auxContinuePtr->expandTarget == envPtr->expandCount) { + auxContinuePtr = NULL; + } + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { + fprintf(stderr,"loop call(%s,d=%d/%d(%d/%d),t=%d/%d(%d))\n", + tclInstructionTable[opcode].name, + (auxBreakPtr?auxBreakPtr->stackDepth:-1), + (auxContinuePtr?auxContinuePtr->stackDepth:-1), + envPtr->currStackDepth, + wordCount, + (auxBreakPtr?auxBreakPtr->expandTarget:-1), + (auxContinuePtr?auxContinuePtr->expandTarget:-1), + envPtr->expandCount); + loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeStarts(envPtr, loopRange); + } + predictedDepth = envPtr->currStackDepth - wordCount; + + /* + * Issue the invoke itself. + */ + + switch (opcode) { + case INST_INVOKE_STK1: + TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr); + break; + case INST_INVOKE_STK4: + TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr); + break; + case INST_INVOKE_EXPANDED: + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + break; + case INST_INVOKE_REPLACE: + TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); + TclEmitInt1(arg2, envPtr); + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + break; + } + + /* + * If we're generating a special wrapper exception range, we need to + * finish that up now. + */ + + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { + int savedStackDepth = envPtr->currStackDepth; + int savedExpandCount = envPtr->expandCount; + JumpFixup nonTrapFixup; + int off; + + ExceptionRangeEnds(envPtr, loopRange); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); + fprintf(stderr,"loop call(d=%d,t=%d|%p,%p)\n",savedStackDepth-1,savedExpandCount,auxBreakPtr,auxContinuePtr); + + /* + * Careful! When generating these stack unwinding sequences, the depth + * of stack in the cases where they are taken is not the same as if + * the exception is not taken. + */ + + if (auxBreakPtr != NULL) { + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + assert(envPtr->currStackDepth == predictedDepth); + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + off = CurrentOffset(envPtr); + TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); + fprintf(stderr,"popped(break):%ld\n",CurrentOffset(envPtr) - off); + TclAddLoopBreakFixup(envPtr, auxBreakPtr); + envPtr->currStackDepth = savedStackDepth; + envPtr->expandCount = savedExpandCount; + } + + if (auxContinuePtr != NULL) { + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + assert(envPtr->currStackDepth == predictedDepth); + ExceptionRangeTarget(envPtr, loopRange, continueOffset); + off = CurrentOffset(envPtr); + TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); + fprintf(stderr,"popped(continue):%ld\n",CurrentOffset(envPtr) - off); + TclAddLoopContinueFixup(envPtr, auxContinuePtr); + envPtr->currStackDepth = savedStackDepth; + envPtr->expandCount = savedExpandCount; + } + + TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); + } +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5660055..a39e0f1 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1021,6 +1021,7 @@ MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, TclJumpType jumpType, JumpFixup *jumpFixupPtr); +MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...); MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, int catchOnly, ByteCode *codePtr); MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index ad11785..9bb7a0c 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3179,9 +3179,7 @@ CompileToInvokedCommand( * Do the replacing dispatch. */ - TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr); - TclEmitInt1(numWords+1, envPtr); - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */ + TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1); } /* -- cgit v0.12 From 891ebfad72cbbda3e8be4ddba83efc541e6cce03 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Oct 2013 21:57:26 +0000 Subject: Update to Unicode 6.3 tables --- generic/regc_locale.c | 22 +++--- generic/tclUniData.c | 196 +++++++++++++++++++++++++------------------------- 2 files changed, 110 insertions(+), 108 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index dd1c01c..69459f1 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -118,7 +118,7 @@ static const struct cname { * Unicode character-class tables. */ -typedef struct crange { +typedef struct { chr start; chr end; } crange; @@ -260,7 +260,7 @@ static const chr alphaCharTable[] = { static const crange controlRangeTable[] = { {0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, - {0x202a, 0x202e}, {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, + {0x202a, 0x202e}, {0x2060, 0x2064}, {0x2066, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb} #if TCL_UTF_MAX > 4 ,{0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, {0x100000, 0x10fffd} @@ -270,7 +270,7 @@ static const crange controlRangeTable[] = { #define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange)) static const chr controlCharTable[] = { - 0xad, 0x6dd, 0x70f, 0xfeff + 0xad, 0x61c, 0x6dd, 0x70f, 0x180e, 0xfeff #if TCL_UTF_MAX > 4 ,0x110bd, 0xe0001 #endif @@ -316,12 +316,13 @@ static const crange punctRangeTable[] = { {0x17d8, 0x17da}, {0x1800, 0x180a}, {0x1aa0, 0x1aa6}, {0x1aa8, 0x1aad}, {0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7}, {0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e}, - {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, {0x29d8, 0x29db}, - {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, {0x3001, 0x3003}, - {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, {0xa6f2, 0xa6f7}, - {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, {0xaa5c, 0xaa5f}, - {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03}, - {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff5f, 0xff65} + {0x2308, 0x230b}, {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, + {0x29d8, 0x29db}, {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, + {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, + {0xa6f2, 0xa6f7}, {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, + {0xaa5c, 0xaa5f}, {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, + {0xff01, 0xff03}, {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, + {0xff5f, 0xff65} #if TCL_UTF_MAX > 4 ,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10b39, 0x10b3f}, {0x11047, 0x1104d}, {0x110be, 0x110c1}, {0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x12470, 0x12473} @@ -361,7 +362,8 @@ static const crange spaceRangeTable[] = { #define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange)) static const chr spaceCharTable[] = { - 0x20, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, 0x3000 + 0x20, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, 0x2060, + 0x3000, 0xfeff }; #define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr)) diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 5c88639..a0d4ccc 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -624,7 +624,7 @@ static const unsigned char groupMap[] = { 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 0, 7, 7, 7, 3, 3, - 4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 0, + 4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 17, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, @@ -792,118 +792,118 @@ static const unsigned char groupMap[] = { 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, 3, 85, 3, 3, 3, 4, 15, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, - 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 2, 0, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 15, 15, 15, 15, 15, + 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 17, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 86, 86, 116, 116, 116, 116, + 86, 86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116, + 116, 116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 86, 86, 116, 116, 116, 116, 86, - 86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116, 116, - 116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, - 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116, 116, 116, 116, - 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 15, 15, 15, - 15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116, + 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, + 15, 15, 15, 15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116, 116, 116, - 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86, 86, 86, - 0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, - 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 86, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3, 3, 3, 3, - 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, - 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 116, - 86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86, 116, 116, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 0, 0, 0, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116, 15, 15, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86, 116, 116, - 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116, 116, 116, - 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, - 86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, - 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 85, 85, 85, 85, 85, 85, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 86, 86, - 15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116, + 116, 86, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86, + 86, 86, 0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, + 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, + 0, 86, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3, + 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, + 86, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 86, 116, 86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86, + 116, 116, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 0, 0, 0, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116, + 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86, + 116, 116, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116, + 116, 116, 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, + 116, 116, 86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 85, 85, 85, 85, 85, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, + 86, 86, 15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21, 21, 21, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86, 86, 86, - 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21, 21, - 122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124, 124, - 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124, 124, - 124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, - 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123, 123, - 124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, - 0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21, 123, - 21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123, 123, - 123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126, 126, - 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123, 123, - 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131, 123, - 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, - 131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, - 131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133, 133, - 134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136, 136, - 134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137, 137, - 0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138, 138, - 109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140, 140, - 134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, 17, - 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, 3, 3, - 3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17, - 17, 17, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, 18, 18, - 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, - 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, 100, - 21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, 100, - 100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, 100, - 100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, 21, - 21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14, 147, - 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, - 148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, - 149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118, 18, - 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14, - 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, + 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86, + 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21, + 21, 122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124, + 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124, + 124, 124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124, + 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123, + 123, 124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, + 123, 0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21, + 123, 21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123, + 123, 123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126, + 126, 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123, + 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131, + 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, + 131, 131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, + 131, 131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133, + 133, 134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136, + 136, 134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137, + 137, 0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138, + 138, 109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140, + 140, 134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, + 17, 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, + 3, 3, 3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, + 17, 17, 17, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, + 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, + 100, 21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, + 100, 100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, + 100, 100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, + 21, 21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14, + 147, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, + 148, 148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, + 149, 149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118, + 18, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, + 14, 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7, - 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, + 7, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, - 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, -- cgit v0.12 From 43a91548b31101b95bc2b2e29ada872bb3d9590e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Oct 2013 14:13:51 +0000 Subject: Fix for bug [f51efe99a7]: MinGW build fails on current checkin. And a new test-case which makes the problem visible on UNIX as well. --- generic/tclOO.h | 5 +- generic/tclOODecls.h | 2 + generic/tclOOStubLib.c | 2 + tests/load.test | 6 +++ unix/dltest/Makefile.in | 13 ++++- unix/dltest/pkgooa.c | 138 ++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 161 insertions(+), 5 deletions(-) create mode 100644 unix/dltest/pkgooa.c diff --git a/generic/tclOO.h b/generic/tclOO.h index 41be168..a6e8a22 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,13 +37,12 @@ extern "C" { #endif -#if (defined(USE_TCLOO_STUBS) || defined(USE_TCL_STUBS)) extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) \ TclOOInitializeStubs((interp), TCLOO_VERSION) -#else -#define Tcl_OOInitStubs(interp) (TCLOO_PATCHLEVEL) +#ifndef USE_TCL_STUBS +# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL) #endif /* diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index c2a5615..e483df6 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -10,6 +10,8 @@ # define TCL_STORAGE_CLASS DLLEXPORT #else # ifdef USE_TCL_STUBS +# undef USE_TCLOO_STUBS +# define USE_TCLOO_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index 921aced..a9fa212 100644 --- a/generic/tclOOStubLib.c +++ b/generic/tclOOStubLib.c @@ -27,6 +27,8 @@ const TclOOIntStubs *tclOOIntStubsPtr = NULL; *---------------------------------------------------------------------- */ +#undef TclOOInitializeStubs + MODULE_SCOPE const char * TclOOInitializeStubs( Tcl_Interp *interp, diff --git a/tests/load.test b/tests/load.test index cded85d..9536271 100644 --- a/tests/load.test +++ b/tests/load.test @@ -215,6 +215,12 @@ test load-10.1 {load from vfs} \ -body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \ -result {0 {}} \ -cleanup {testsimplefilesystem 0; cd $dir; unset dir} + +test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ + [list $dll $loaded] { + load [file join $testDir pkgooa$ext] + list [pkgooa_stubsok] [lsort [info commands pkgooa_*]] +} {1 pkgooa_stubsok} # cleanup unset ext diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 01589d9..f64b6d5 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -25,11 +25,11 @@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -I${BUILD_DIR}/.. -DTCL_MEM_DEBUG \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} -all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} +all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} pkgooa${SHLIB_SUFFIX} @if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi @touch ../dltest.marker -dltest_suffix: pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} pkgd${DLTEST_SUFFIX} pkge${DLTEST_SUFFIX} pkgua${DLTEST_SUFFIX} +dltest_suffix: pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} pkgd${DLTEST_SUFFIX} pkge${DLTEST_SUFFIX} pkgua${DLTEST_SUFFIX} pkgooa${DLTEST_SUFFIX} @touch ../dltest.marker pkga.o: $(SRC_DIR)/pkga.c @@ -50,6 +50,9 @@ pkge.o: $(SRC_DIR)/pkge.c pkgua.o: $(SRC_DIR)/pkgua.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgua.c +pkgooa.o: $(SRC_DIR)/pkgooa.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgooa.c + pkga${SHLIB_SUFFIX}: pkga.o ${SHLIB_LD} -o pkga${SHLIB_SUFFIX} pkga.o ${SHLIB_LD_LIBS} @@ -68,6 +71,9 @@ pkge${SHLIB_SUFFIX}: pkge.o pkgua${SHLIB_SUFFIX}: pkgua.o ${SHLIB_LD} -o pkgua${SHLIB_SUFFIX} pkgua.o ${SHLIB_LD_LIBS} +pkgooa${SHLIB_SUFFIX}: pkgooa.o + ${SHLIB_LD} -o pkgooa${SHLIB_SUFFIX} pkgooa.o ${SHLIB_LD_LIBS} + pkga${DLTEST_SUFFIX}: pkga.o ${DLTEST_LD} -o pkga${DLTEST_SUFFIX} pkga.o ${SHLIB_LD_LIBS} @@ -86,6 +92,9 @@ pkge${DLTEST_SUFFIX}: pkge.o pkgua${DLTEST_SUFFIX}: pkgua.o ${DLTEST_LD} -o pkgua${DLTEST_SUFFIX} pkgua.o ${SHLIB_LD_LIBS} +pkgooa${DLTEST_SUFFIX}: pkgooa.o + ${DLTEST_LD} -o pkgooa${DLTEST_SUFFIX} pkgooa.o ${SHLIB_LD_LIBS} + clean: rm -f *.o lib.exp ../dltest.marker @if test "$(SHLIB_SUFFIX)" != ""; then \ diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c new file mode 100644 index 0000000..bdac9db --- /dev/null +++ b/unix/dltest/pkgooa.c @@ -0,0 +1,138 @@ +/* + * pkgooa.c -- + * + * This file contains a simple Tcl package "pkgooa" that is intended for + * testing the Tcl dynamic loading facilities. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#undef STATIC_BUILD +#include "tclOO.h" +#include + +/* + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the + * Pkgooa_Init declaration is in the source file itself, which is only + * accessed when we are building a library. + */ +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgooa_StubsOKObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); + + +/* + *---------------------------------------------------------------------- + * + * Pkgooa_StubsOKObjCmd -- + * + * This procedure is invoked to process the "pkgooa_stubsok" Tcl command. + * It gives 1 if stubs are used correctly, 0 if stubs are not OK. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgooa_StubsOKObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_CopyObjectInstance == tclOOStubsPtr->tcl_CopyObjectInstance)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgooa_Init -- + * + * This is a package initialization procedure, which is called by Tcl + * when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Object copyObjectInstance(Tcl_Interp *interp, + Tcl_Object source, const char *name, const char *nameSpace) +{ + Tcl_Object result; + result = Tcl_CopyObjectInstance(interp, source, name, nameSpace); + if (result == NULL) { + Tcl_AppendResult(interp, "ERROR: copy failed."); + } + return result; +} + +static TclOOStubs stubsCopy = { + TCL_STUB_MAGIC, + NULL, + copyObjectInstance + /* more entries here, but those are not + * needed for this test-case. */ +}; + +EXTERN int +Pkgooa_Init( + Tcl_Interp *interp) /* Interpreter in which the package is to be + * made available. */ +{ + int code; + + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + return TCL_ERROR; + } + if (Tcl_OOInitStubs(interp) == NULL) { + return TCL_ERROR; + } + + /* Test case for Bug [f51efe99a7]. + * + * Let tclOOStubsPtr point to an alternate stub table + * (with only a single function, that's enough for + * this test). This way, the function "pkgooa_stubsok" + * can check whether the TclOO function calls really + * use the stub table, or only pretend to. + * + * On platforms without backlinking (Windows, Cygwin, + * AIX), this code doesn't even compile without using + * stubs, but on UNIX ELF systems, the problem is + * less visible. + */ + + tclOOStubsPtr = &stubsCopy; + + code = Tcl_PkgProvide(interp, "Pkgooa", "1.0"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateObjCommand(interp, "pkgooa_stubsok", Pkgooa_StubsOKObjCmd, NULL, NULL); + return TCL_OK; +} -- cgit v0.12 From 7d1b223f7df36d45707d0c6325c3c5665b324724 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 10 Oct 2013 21:24:15 +0000 Subject: [98c8b3ec12] Use constraint to work around failing test; it's just a bug in the underlying library, and one that appears fixed in later versions. Not our fault if some OSes don't update. (It's also in a very esoteric spot.) --- tests/zlib.test | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/tests/zlib.test b/tests/zlib.test index 0712929..4e51ebb 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -16,6 +16,13 @@ if {"::tcltest" ni [namespace children]} { } testConstraint zlib [llength [info commands zlib]] +testConstraint recentZlib 0 +catch { + # Work around a bug in some versions of zlib; known to manifest on at + # least Mac OS X Mountain Lion... + testConstraint recentZlib \ + [package vsatisfies [zlib::pkgconfig get zlibVersion] 1.2.6] +} test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body { zlib @@ -269,7 +276,7 @@ test zlib-8.9 {transformation and fconfigure} -setup { } -result {3064818174 358 358} test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide -} -constraints zlib -body { +} -constraints {zlib recentZlib} -body { zlib push deflate $outSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary -- cgit v0.12 From 1fa1578500c58be8eed071fcbdce604c32b418cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Oct 2013 10:26:35 +0000 Subject: Even though TCLOO_PATCHLEVEL is equal to TCLOO_VERSION, using "patchlevel" is more appropriate in those two places. --- generic/tclOO.c | 2 +- tests/oo.test | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index cb22de6..529640f 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -271,7 +271,7 @@ TclOOInit( return TCL_ERROR; } - return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_VERSION, + return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, (ClientData) &tclOOStubs); } diff --git a/tests/oo.test b/tests/oo.test index 37bbadb..d63e931 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -101,7 +101,7 @@ test oo-0.8 {leak in variable management} -setup { test oo-0.9 {various types of presence of the TclOO package} { list [lsearch -nocase -all -inline [package names] tcloo] \ [package present TclOO] [package versions TclOO] -} [list TclOO $::oo::version $::oo::version] +} [list TclOO $::oo::patchlevel $::oo::patchlevel] test oo-1.1 {basic test of OO functionality: no classes} { set result {} -- cgit v0.12 From 2dc26cc732ba64065c0bf64d8c63a2c82c539999 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Oct 2013 10:45:08 +0000 Subject: Allow loading of pkgooa.so in Tcl 8.5 for (regression) test purposes. Better error messages in stead of crashes in some (hypothetical) error situations. --- unix/dltest/pkgooa.c | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index bdac9db..c0c1605 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -106,12 +106,29 @@ Pkgooa_Init( { int code; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + /* Any TclOO extension which uses stubs, calls + * both Tcl_InitStubs and Tcl_OOInitStubs() and + * does not use any Tcl 8.6 features should be + * loadable in Tcl 8.5 as well, provided the + * TclOO extension (for Tcl 8.5) is installed. + * This worked in Tcl 8.6.0, and is expected + * to keep working in all future Tcl 8.x releases. + */ + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + return TCL_ERROR; + } + if (tclStubsPtr == NULL) { + Tcl_AppendResult(interp, "Tcl stubs are not inialized, " + "did you compile using -DUSE_TCL_STUBS? "); return TCL_ERROR; } if (Tcl_OOInitStubs(interp) == NULL) { return TCL_ERROR; } + if (tclOOStubsPtr == NULL) { + Tcl_AppendResult(interp, "TclOO stubs are not inialized"); + return TCL_ERROR; + } /* Test case for Bug [f51efe99a7]. * -- cgit v0.12 From 18620aebd7623aaa3031162500c392cf2fa6ade7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 13 Oct 2013 12:09:22 +0000 Subject: Stop crashing in interactive testing. (The unknown and history mechanisms tend to exercise some parts of the bytecode compiler very well.) --- generic/tclCompile.c | 49 ++++++++++++++++++++++++++++++------------------- 1 file changed, 30 insertions(+), 19 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a5b0bd8..74a9c8c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3911,6 +3911,7 @@ TclEmitInvoke( ExceptionRange *rangePtr; ExceptionAux *auxBreakPtr, *auxContinuePtr; int arg1, arg2, wordCount = 0, loopRange, predictedDepth; + int breakRange = -1, continueRange = -1; /* * Parse the arguments. @@ -3943,6 +3944,9 @@ TclEmitInvoke( * Determine if we need to handle break and continue exceptions with a * special handling exception range (so that we can correctly unwind the * stack). + * + * These must be done separately; they can be different (especially for + * calls from inside a [for] increment clause). */ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr); @@ -3951,7 +3955,10 @@ TclEmitInvoke( } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount && auxBreakPtr->expandTarget == envPtr->expandCount) { auxBreakPtr = NULL; + } else { + breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; } + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxContinuePtr); if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { @@ -3959,17 +3966,11 @@ TclEmitInvoke( } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount && auxContinuePtr->expandTarget == envPtr->expandCount) { auxContinuePtr = NULL; + } else { + continueRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; } + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - fprintf(stderr,"loop call(%s,d=%d/%d(%d/%d),t=%d/%d(%d))\n", - tclInstructionTable[opcode].name, - (auxBreakPtr?auxBreakPtr->stackDepth:-1), - (auxContinuePtr?auxContinuePtr->stackDepth:-1), - envPtr->currStackDepth, - wordCount, - (auxBreakPtr?auxBreakPtr->expandTarget:-1), - (auxContinuePtr?auxContinuePtr->expandTarget:-1), - envPtr->expandCount); loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); ExceptionRangeStarts(envPtr, loopRange); } @@ -4005,11 +4006,17 @@ TclEmitInvoke( int savedStackDepth = envPtr->currStackDepth; int savedExpandCount = envPtr->expandCount; JumpFixup nonTrapFixup; - int off; + ExceptionAux *exceptAux = envPtr->exceptAuxArrayPtr + loopRange; + + if (auxBreakPtr != NULL) { + auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; + } + if (auxContinuePtr != NULL) { + auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange; + } ExceptionRangeEnds(envPtr, loopRange); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); - fprintf(stderr,"loop call(d=%d,t=%d|%p,%p)\n",savedStackDepth-1,savedExpandCount,auxBreakPtr,auxContinuePtr); /* * Careful! When generating these stack unwinding sequences, the depth @@ -4018,25 +4025,29 @@ TclEmitInvoke( */ if (auxBreakPtr != NULL) { - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + TclAdjustStackDepth(-1, envPtr); assert(envPtr->currStackDepth == predictedDepth); + exceptAux->stackDepth = auxBreakPtr->stackDepth; + exceptAux->expandTarget = auxBreakPtr->expandTarget; + ExceptionRangeTarget(envPtr, loopRange, breakOffset); - off = CurrentOffset(envPtr); - TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); - fprintf(stderr,"popped(break):%ld\n",CurrentOffset(envPtr) - off); + TclCleanupStackForBreakContinue(envPtr, exceptAux); TclAddLoopBreakFixup(envPtr, auxBreakPtr); + envPtr->currStackDepth = savedStackDepth; envPtr->expandCount = savedExpandCount; } if (auxContinuePtr != NULL) { - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + TclAdjustStackDepth(-1, envPtr); assert(envPtr->currStackDepth == predictedDepth); + exceptAux->stackDepth = auxContinuePtr->stackDepth; + exceptAux->expandTarget = auxContinuePtr->expandTarget; + ExceptionRangeTarget(envPtr, loopRange, continueOffset); - off = CurrentOffset(envPtr); - TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); - fprintf(stderr,"popped(continue):%ld\n",CurrentOffset(envPtr) - off); + TclCleanupStackForBreakContinue(envPtr, exceptAux); TclAddLoopContinueFixup(envPtr, auxContinuePtr); + envPtr->currStackDepth = savedStackDepth; envPtr->expandCount = savedExpandCount; } -- cgit v0.12 From 62cb43456456d34b7a1b738feb2d2114915aff3c Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 13 Oct 2013 13:34:01 +0000 Subject: update comments --- generic/tclCompCmdsGR.c | 1 + generic/tclCompile.c | 21 +++++++++++++++++++++ 2 files changed, 22 insertions(+) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 43ea3d3..3efcba7 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2480,6 +2480,7 @@ TclCompileReturnCmd( * emit the INST_RETURN_IMM instruction with code and level as operands. */ + // TODO: when (code==TCL_BREAK || code==TCL_CONTINUE)&&(level==0&&size==0), check for stack balance and jump opportunities CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); return TCL_OK; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 74a9c8c..68b7649 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3901,6 +3901,27 @@ TclFixupForwardJump( return 1; /* the jump was grown */ } +/* + *---------------------------------------------------------------------- + * + * TclEmitInvoke -- + * + * Emit one of the invoke-related instructions, wrapping it if necessary + * in code that ensures that any break or continue operation passing + * through it gets the stack unwinding correct, converting it into an + * internal jump if in an appropriate context. + * + * Results: + * None + * + * Side effects: + * Issues the jump with all correct stack management. May create another + * loop exception range; pointers to ExceptionRange and ExceptionAux + * structures should not be held across this call. + * + *---------------------------------------------------------------------- + */ + void TclEmitInvoke( CompileEnv *envPtr, -- cgit v0.12 From 9adfa74f671acd5bcc33247b07176d117eda3357 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 13 Oct 2013 13:57:27 +0000 Subject: Added the tests I want to pass... --- tests/for.test | 126 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 126 insertions(+) diff --git a/tests/for.test b/tests/for.test index 8936682..6a18abe 100644 --- a/tests/for.test +++ b/tests/for.test @@ -942,6 +942,132 @@ test for-7.8 {Bug 3614226: ensure that continue only cleans up the right amount} expr {$end - $tmp} }} } 0 +test for-7.9 {Bug 3614226: ensure that break from invoked command cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [apply {{} {return -code break}}] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.10 {Bug 3614226: ensure that continue from invoked command cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [apply {{} {return -code continue}}] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.11 {Bug 3614226: ensure that break from invoked command cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[apply {{} {return -code break}}] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.12 {Bug 3614226: ensure that continue from invoked command cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[apply {{} { + return -code continue + }}] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.13 {Bug 3614226: ensure that break from invoked command cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code break + }}] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.14 {Bug 3614226: ensure that continue from invoked command cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code continue + }}] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.15 {Bug 3614226: ensure that break from invoked command only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code break + }}] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.16 {Bug 3614226: ensure that continue from invoked command only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code continue + }}] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 5ab205e3a03e8c73052ecffe7173cb205398c779 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Oct 2013 15:32:46 +0000 Subject: Add note to ChangeLog, copied from Tcl 8.6 ChangeLog note --- ChangeLog | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/ChangeLog b/ChangeLog index 7b1cb0f..b11d763 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,26 @@ +A NOTE ON THE CHANGELOG: +Starting in early 2011, Tcl source code has been under the management of +fossil, hosted at http://core.tcl.tk/tcl/ . Fossil presents a "Timeline" +view of changes made that is superior in every way to a hand edited log file. +Because of this, many Tcl developers are now out of the habit of maintaining +this log file. You may still find useful things in it, but the Timeline is +a better first place to look now. +============================================================================ + +2013-09-19 Don Porter + + *** 8.6.1 TAGGED FOR RELEASE *** + + * generic/tcl.h: Bump version number to 8.6.1. + * library/init.tcl: + * unix/configure.in: + * win/configure.in: + * unix/tcl.spec: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + 2013-09-19 Donal Fellows * doc/next.n (METHOD SEARCH ORDER): Bug [3606943]: Corrected -- cgit v0.12 From a31cc592a4e4c6d1ba5a4f0e12457adcfe668d15 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Oct 2013 16:19:44 +0000 Subject: The Tcl 9.0 way of how [dfc08326e3] should be fixed: Real integration of TclOO in Tcl means that calling the function Tcl_OOInitStubs() should be elminated in full. This branch shows how to do that. --- generic/tcl.decls | 3 +- generic/tclDecls.h | 1 + generic/tclOO.h | 9 +---- generic/tclOOStubLib.c | 71 ------------------------------------ generic/tclStubInit.c | 10 ++++- generic/tclStubLib.c | 13 +++++++ macosx/Tcl.xcode/project.pbxproj | 4 -- macosx/Tcl.xcodeproj/project.pbxproj | 4 -- unix/Makefile.in | 7 +--- win/Makefile.in | 6 +-- win/makefile.bc | 6 +-- win/makefile.vc | 6 +-- win/tcl.dsp | 4 -- 13 files changed, 31 insertions(+), 113 deletions(-) delete mode 100644 generic/tclOOStubLib.c diff --git a/generic/tcl.decls b/generic/tcl.decls index 734aae7..005b513 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -18,9 +18,10 @@ library tcl # tclPlat - platform specific public # tclInt - generic private # tclPlatInt - platform specific private +# tclOO - tclOO public interface tcl -hooks {tclPlat tclInt tclIntPlat} +hooks {tclPlat tclInt tclIntPlat tclOO} scspec TCLAPI # Declare each of the functions in the public Tcl interface. Note that diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e38f752..673726b 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1731,6 +1731,7 @@ typedef struct { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; const struct TclIntPlatStubs *tclIntPlatStubs; + const struct TclOOStubs *tclOOStubs; } TclStubHooks; typedef struct TclStubs { diff --git a/generic/tclOO.h b/generic/tclOO.h index a6e8a22..b8aa974 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,13 +37,8 @@ extern "C" { #endif -extern const char *TclOOInitializeStubs( - Tcl_Interp *, const char *version); -#define Tcl_OOInitStubs(interp) \ - TclOOInitializeStubs((interp), TCLOO_VERSION) -#ifndef USE_TCL_STUBS -# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL) -#endif +#define Tcl_OOInitStubs(interp) (TCLOO_PATCHLEVEL) +#define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL) /* * These are opaque types. diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c deleted file mode 100644 index a9fa212..0000000 --- a/generic/tclOOStubLib.c +++ /dev/null @@ -1,71 +0,0 @@ -/* - * ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 - */ - -#include "tclOOInt.h" - -MODULE_SCOPE const TclOOStubs *tclOOStubsPtr; -MODULE_SCOPE const TclOOIntStubs *tclOOIntStubsPtr; - -const TclOOStubs *tclOOStubsPtr = NULL; -const TclOOIntStubs *tclOOIntStubsPtr = NULL; - -/* - *---------------------------------------------------------------------- - * - * TclOOInitializeStubs -- - * Load the tclOO package, initialize stub table pointer. Do not call - * this function directly, use Tcl_OOInitStubs() macro instead. - * - * Results: - * The actual version of the package that satisfies the request, or NULL - * to indicate that an error occurred. - * - * Side effects: - * Sets the stub table pointers. - * - *---------------------------------------------------------------------- - */ - -#undef TclOOInitializeStubs - -MODULE_SCOPE const char * -TclOOInitializeStubs( - Tcl_Interp *interp, - const char *version) -{ - int exact = 0; - const char *packageName = "TclOO"; - const char *errMsg = NULL; - TclOOStubs *stubsPtr = NULL; - const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, - packageName, version, exact, &stubsPtr); - - if (actualVersion == NULL) { - return NULL; - } - if (stubsPtr == NULL) { - errMsg = "missing stub table pointer"; - } else { - tclOOStubsPtr = stubsPtr; - if (stubsPtr->hooks) { - tclOOIntStubsPtr = stubsPtr->hooks->tclOOIntStubs; - } else { - tclOOIntStubsPtr = NULL; - } - return actualVersion; - } - tclStubsPtr->tcl_ResetResult(interp); - tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName, - " (requested version ", version, ", actual version ", - actualVersion, "): ", errMsg, NULL); - return NULL; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 5fb501a..1ec155a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -10,8 +10,15 @@ */ #include "tclInt.h" +#include "tclOOInt.h" #include "tommath.h" +/* + * The actual definition of the variable holding the TclOO stub table. + */ + +MODULE_SCOPE const TclOOStubs tclOOStubs; + #ifdef __GNUC__ #pragma GCC dependency "tcl.decls" #pragma GCC dependency "tclInt.decls" @@ -694,7 +701,8 @@ const TclTomMathStubs tclTomMathStubs = { static const TclStubHooks tclStubHooks = { &tclPlatStubs, &tclIntStubs, - &tclIntPlatStubs + &tclIntPlatStubs, + &tclOOStubs }; const TclStubs tclStubs = { diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 3e4a5ae..6487ebb 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -12,16 +12,21 @@ */ #include "tclInt.h" +#include "tclOOInt.h" MODULE_SCOPE const TclStubs *tclStubsPtr; MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr; MODULE_SCOPE const TclIntStubs *tclIntStubsPtr; MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr; +MODULE_SCOPE const TclOOStubs *tclOOStubsPtr; +MODULE_SCOPE const TclOOIntStubs *tclOOIntStubsPtr; const TclStubs *tclStubsPtr = NULL; const TclPlatStubs *tclPlatStubsPtr = NULL; const TclIntStubs *tclIntStubsPtr = NULL; const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; +const TclOOStubs *tclOOStubsPtr = NULL; +const TclOOIntStubs *tclOOIntStubsPtr = NULL; /* * Use our own ISDIGIT to avoid linking to libc on windows @@ -113,10 +118,18 @@ Tcl_InitStubs( tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs; tclIntStubsPtr = stubsPtr->hooks->tclIntStubs; tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs; + tclOOStubsPtr = stubsPtr->hooks->tclOOStubs; + if (tclOOStubsPtr && tclOOStubsPtr->hooks) { + tclOOIntStubsPtr = tclOOStubsPtr->hooks->tclOOIntStubs; + } else { + tclOOIntStubsPtr = NULL; + } } else { tclPlatStubsPtr = NULL; tclIntStubsPtr = NULL; tclIntPlatStubsPtr = NULL; + tclOOStubsPtr = NULL; + tclOOIntStubsPtr = NULL; } return actualVersion; diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj index a2a703b..7fb918e 100644 --- a/macosx/Tcl.xcode/project.pbxproj +++ b/macosx/Tcl.xcode/project.pbxproj @@ -15,7 +15,6 @@ F93599BE0DF1F77400E04F67 /* tclOOInfo.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599BD0DF1F77400E04F67 /* tclOOInfo.c */; }; F93599C20DF1F78300E04F67 /* tclOOMethod.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599C10DF1F78300E04F67 /* tclOOMethod.c */; }; F93599C40DF1F78800E04F67 /* tclOOStubInit.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599C30DF1F78800E04F67 /* tclOOStubInit.c */; }; - F93599C60DF1F78D00E04F67 /* tclOOStubLib.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599C50DF1F78D00E04F67 /* tclOOStubLib.c */; }; F95D77EA0DFD820D00A8BF6F /* tclIORTrans.c in Sources */ = {isa = PBXBuildFile; fileRef = F95D77E90DFD820D00A8BF6F /* tclIORTrans.c */; }; F96437CA0EF0D4B2003F468E /* tclZlib.c in Sources */ = {isa = PBXBuildFile; fileRef = F96437C90EF0D4B2003F468E /* tclZlib.c */; }; F96437E70EF0D652003F468E /* libz.dylib in Frameworks */ = {isa = PBXBuildFile; fileRef = F96437E60EF0D652003F468E /* libz.dylib */; }; @@ -209,7 +208,6 @@ F93599C00DF1F77D00E04F67 /* tclOOIntDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclOOIntDecls.h; sourceTree = ""; }; F93599C10DF1F78300E04F67 /* tclOOMethod.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOMethod.c; sourceTree = ""; }; F93599C30DF1F78800E04F67 /* tclOOStubInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOStubInit.c; sourceTree = ""; }; - F93599C50DF1F78D00E04F67 /* tclOOStubLib.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOStubLib.c; sourceTree = ""; }; F93599C80DF1F81900E04F67 /* oo.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = oo.test; sourceTree = ""; }; F93599CF0DF1F87F00E04F67 /* Class.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Class.3; sourceTree = ""; }; F93599D00DF1F89E00E04F67 /* class.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = class.n; sourceTree = ""; }; @@ -1289,7 +1287,6 @@ F93599C00DF1F77D00E04F67 /* tclOOIntDecls.h */, F93599C10DF1F78300E04F67 /* tclOOMethod.c */, F93599C30DF1F78800E04F67 /* tclOOStubInit.c */, - F93599C50DF1F78D00E04F67 /* tclOOStubLib.c */, F96D3F0E08F272A7004A47F5 /* tclPanic.c */, F96D3F0F08F272A7004A47F5 /* tclParse.c */, F96D3F1108F272A7004A47F5 /* tclPathObj.c */, @@ -2023,7 +2020,6 @@ F93599BE0DF1F77400E04F67 /* tclOOInfo.c in Sources */, F93599C20DF1F78300E04F67 /* tclOOMethod.c in Sources */, F93599C40DF1F78800E04F67 /* tclOOStubInit.c in Sources */, - F93599C60DF1F78D00E04F67 /* tclOOStubLib.c in Sources */, F96D45AD08F272BC004A47F5 /* tclPanic.c in Sources */, F96D45AE08F272BC004A47F5 /* tclParse.c in Sources */, F96D45B008F272BC004A47F5 /* tclPathObj.c in Sources */, diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index 9c18ac0..ddd5e3b 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -15,7 +15,6 @@ F93599BE0DF1F77400E04F67 /* tclOOInfo.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599BD0DF1F77400E04F67 /* tclOOInfo.c */; }; F93599C20DF1F78300E04F67 /* tclOOMethod.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599C10DF1F78300E04F67 /* tclOOMethod.c */; }; F93599C40DF1F78800E04F67 /* tclOOStubInit.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599C30DF1F78800E04F67 /* tclOOStubInit.c */; }; - F93599C60DF1F78D00E04F67 /* tclOOStubLib.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599C50DF1F78D00E04F67 /* tclOOStubLib.c */; }; F95D77EA0DFD820D00A8BF6F /* tclIORTrans.c in Sources */ = {isa = PBXBuildFile; fileRef = F95D77E90DFD820D00A8BF6F /* tclIORTrans.c */; }; F96437CA0EF0D4B2003F468E /* tclZlib.c in Sources */ = {isa = PBXBuildFile; fileRef = F96437C90EF0D4B2003F468E /* tclZlib.c */; }; F96437E70EF0D652003F468E /* libz.dylib in Frameworks */ = {isa = PBXBuildFile; fileRef = F96437E60EF0D652003F468E /* libz.dylib */; }; @@ -209,7 +208,6 @@ F93599C00DF1F77D00E04F67 /* tclOOIntDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclOOIntDecls.h; sourceTree = ""; }; F93599C10DF1F78300E04F67 /* tclOOMethod.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOMethod.c; sourceTree = ""; }; F93599C30DF1F78800E04F67 /* tclOOStubInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOStubInit.c; sourceTree = ""; }; - F93599C50DF1F78D00E04F67 /* tclOOStubLib.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOStubLib.c; sourceTree = ""; }; F93599C80DF1F81900E04F67 /* oo.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = oo.test; sourceTree = ""; }; F93599CF0DF1F87F00E04F67 /* Class.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Class.3; sourceTree = ""; }; F93599D00DF1F89E00E04F67 /* class.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = class.n; sourceTree = ""; }; @@ -1289,7 +1287,6 @@ F93599C00DF1F77D00E04F67 /* tclOOIntDecls.h */, F93599C10DF1F78300E04F67 /* tclOOMethod.c */, F93599C30DF1F78800E04F67 /* tclOOStubInit.c */, - F93599C50DF1F78D00E04F67 /* tclOOStubLib.c */, F96D3F0E08F272A7004A47F5 /* tclPanic.c */, F96D3F0F08F272A7004A47F5 /* tclParse.c */, F96D3F1108F272A7004A47F5 /* tclPathObj.c */, @@ -2023,7 +2020,6 @@ F93599BE0DF1F77400E04F67 /* tclOOInfo.c in Sources */, F93599C20DF1F78300E04F67 /* tclOOMethod.c in Sources */, F93599C40DF1F78800E04F67 /* tclOOStubInit.c in Sources */, - F93599C60DF1F78D00E04F67 /* tclOOStubLib.c in Sources */, F96D45AD08F272BC004A47F5 /* tclPanic.c in Sources */, F96D45AE08F272BC004A47F5 /* tclParse.c in Sources */, F96D45B008F272BC004A47F5 /* tclPathObj.c in Sources */, diff --git a/unix/Makefile.in b/unix/Makefile.in index 309e229..67bbd49 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -337,7 +337,6 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ STUB_LIB_OBJS = tclStubLib.o \ tclTomMathStubLib.o \ - tclOOStubLib.o \ ${COMPAT_OBJS} UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ @@ -475,8 +474,7 @@ OO_SRCS = \ STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ - $(GENERIC_DIR)/tclTomMathStubLib.c \ - $(GENERIC_DIR)/tclOOStubLib.c + $(GENERIC_DIR)/tclTomMathStubLib.c TOMMATH_SRCS = \ $(TOMMATH_DIR)/bncore.c \ @@ -1696,9 +1694,6 @@ tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c tclTomMathStubLib.o: $(GENERIC_DIR)/tclTomMathStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclTomMathStubLib.c -tclOOStubLib.o: $(GENERIC_DIR)/tclOOStubLib.c - $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclOOStubLib.c - .c.o: $(CC) -c $(CC_SWITCHES) $< diff --git a/win/Makefile.in b/win/Makefile.in index be82d73..6f27856 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -385,8 +385,7 @@ REG_OBJS = tclWinReg.$(OBJEXT) STUB_OBJS = \ tclStubLib.$(OBJEXT) \ - tclTomMathStubLib.$(OBJEXT) \ - tclOOStubLib.$(OBJEXT) + tclTomMathStubLib.$(OBJEXT) TCLSH_OBJS = tclAppInit.$(OBJEXT) @@ -518,9 +517,6 @@ tclStubLib.${OBJEXT}: tclStubLib.c tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) -tclOOStubLib.${OBJEXT}: tclOOStubLib.c - $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) - # Implicit rule for all object files that will end up in the Tcl library %.${OBJEXT}: %.c diff --git a/win/makefile.bc b/win/makefile.bc index f6e32f9..73fbc19 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -279,8 +279,7 @@ TCLOBJS = \ TCLSTUBOBJS = \ $(TMPDIR)\tclStubLib.obj \ - $(TMPDIR)\tclTomMathStubLib.obj \ - $(TMPDIR)\tclOOStubLib.obj + $(TMPDIR)\tclTomMathStubLib.obj WINDIR = $(ROOT)\win GENERICDIR = $(ROOT)\generic @@ -531,9 +530,6 @@ $(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c $(TMPDIR)\tclTomMathStubLib.obj : $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? -$(TMPDIR)\tclOOStubLib.obj : $(GENERICDIR)\tclOOStubLib.c - $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $? - # Dedependency rules diff --git a/win/makefile.vc b/win/makefile.vc index b76a939..e3851c9 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -450,8 +450,7 @@ TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ - $(TMP_DIR)\tclTomMathStubLib.obj \ - $(TMP_DIR)\tclOOStubLib.obj + $(TMP_DIR)\tclTomMathStubLib.obj ### The following paths CANNOT have spaces in them. COMPATDIR = $(ROOT)\compat @@ -982,9 +981,6 @@ $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? -$(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c - $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? - #--------------------------------------------------------------------- # Generate the source dependencies. Having dependency rules will # improve incremental build accuracy without having to resort to a diff --git a/win/tcl.dsp b/win/tcl.dsp index 57ec6bf..96152b8 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1300,10 +1300,6 @@ SOURCE=..\generic\tclStubLib.c # End Source File # Begin Source File -SOURCE=..\generic\tclOOStubLib.c -# End Source File -# Begin Source File - SOURCE=..\generic\tclTomMathStubLib.c # End Source File # Begin Source File -- cgit v0.12 From f733ed21e53f84b8359aa0130c90b30318123f67 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Oct 2013 17:22:28 +0000 Subject: Fix definition of TCLAPI macro, when Tcl header files are used from within C++. --- generic/tcl.h | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index f4e503c..ba94281 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -214,9 +214,11 @@ extern "C" { */ #ifdef BUILD_tcl -# define TCLAPI DLLEXPORT +# define TCLAPI extern DLLEXPORT +#elif defined(__cplusplus) +# define TCLAPI extern "C" DLLIMPORT #else -# define TCLAPI DLLIMPORT +# define TCLAPI extern DLLIMPORT #endif /* -- cgit v0.12 From d02f468b979104d4c98a39347be7960486530e1c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Oct 2013 08:11:59 +0000 Subject: Fix comment in tclOO.decls: tclOOStubLib.c is not generated by "make genstubs". In pkgooa.c, check whether the internal TclOO stub table is initialized correctly as well, some internal simplifications and improved comments. --- generic/tclOO.decls | 3 +-- unix/dltest/pkgooa.c | 48 ++++++++++++++++-------------------------------- 2 files changed, 17 insertions(+), 34 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 4f1987c..5d6f2c2 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -3,8 +3,7 @@ # This file contains the declarations for all supported public functions # that are exported by the TclOO package that is embedded within the Tcl # library via the stubs table. This file is used to generate the -# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c -# files. +# tclOODecls.h, tclOOIntDecls.h and tclOOStubInit.c files. # # Copyright (c) 2008-2013 by Donal K. Fellows. # diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index c0c1605..7b14ca0 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -11,24 +11,8 @@ */ #undef STATIC_BUILD -#include "tclOO.h" +#include "tclOOInt.h" #include - -/* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the - * Pkgooa_Init declaration is in the source file itself, which is only - * accessed when we are building a library. - */ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT - -/* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgooa_StubsOKObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - /* *---------------------------------------------------------------------- @@ -80,26 +64,22 @@ Pkgooa_StubsOKObjCmd( *---------------------------------------------------------------------- */ -static Tcl_Object copyObjectInstance(Tcl_Interp *interp, - Tcl_Object source, const char *name, const char *nameSpace) -{ - Tcl_Object result; - result = Tcl_CopyObjectInstance(interp, source, name, nameSpace); - if (result == NULL) { - Tcl_AppendResult(interp, "ERROR: copy failed."); - } - return result; -} - static TclOOStubs stubsCopy = { TCL_STUB_MAGIC, NULL, - copyObjectInstance - /* more entries here, but those are not - * needed for this test-case. */ + /* It doesn't really matter what implementation of + * Tcl_CopyObjectInstance is put in the "pseudo" + * stub table, since the test-case never actually + * calls this function. All that matters is that it's + * a function with a different memory address than + * the real Tcl_CopyObjectInstance function in Tcl. */ + (Tcl_Object (*) (Tcl_Interp *, Tcl_Object, const char *, + const char *t)) Pkgooa_StubsOKObjCmd + /* More entries could be here, but those are not used + * for this test-case. So, being NULL is OK. */ }; -EXTERN int +extern DLLEXPORT int Pkgooa_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ @@ -129,6 +109,10 @@ Pkgooa_Init( Tcl_AppendResult(interp, "TclOO stubs are not inialized"); return TCL_ERROR; } + if (tclOOIntStubsPtr == NULL) { + Tcl_AppendResult(interp, "TclOO internal stubs are not inialized"); + return TCL_ERROR; + } /* Test case for Bug [f51efe99a7]. * -- cgit v0.12 From 71bcf95b719518cd64e068921561bcd2a503598e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Oct 2013 08:34:48 +0000 Subject: Tcl_SetResult -> Tcl_SetObjResult in two places (for Cygwin64 only). --- generic/tclStubInit.c | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 782bbdf..3f1c27b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -234,9 +234,8 @@ static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { - Tcl_SetResult(interp, - "integer value too large to represent as non-long integer", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent as non-long integer", -1)); result = TCL_ERROR; } } @@ -251,9 +250,8 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { - Tcl_SetResult(interp, - "integer value too large to represent as non-long integer", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent as non-long integer", -1)); result = TCL_ERROR; } } -- cgit v0.12 From 21e6601f4971f249f7681508432b98605729fb9d Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 15 Oct 2013 00:27:56 +0000 Subject: Do jump generation at places where INST_RETURN_IMM might occur. --- generic/tclCompCmdsGR.c | 18 +++++++++++++- generic/tclCompile.c | 6 +---- generic/tclOptimize.c | 18 +++++++++++++- tests/compile.test | 64 +++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 99 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 3efcba7..5513b01 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2480,7 +2480,6 @@ TclCompileReturnCmd( * emit the INST_RETURN_IMM instruction with code and level as operands. */ - // TODO: when (code==TCL_BREAK || code==TCL_CONTINUE)&&(level==0&&size==0), check for stack balance and jump opportunities CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); return TCL_OK; @@ -2522,6 +2521,23 @@ CompileReturnInternal( int level, Tcl_Obj *returnOpts) { + if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) { + ExceptionRange *rangePtr; + ExceptionAux *exceptAux; + + rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux); + if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { + TclCleanupStackForBreakContinue(envPtr, exceptAux); + if (code == TCL_BREAK) { + TclAddLoopBreakFixup(envPtr, exceptAux); + } else { + TclAddLoopContinueFixup(envPtr, exceptAux); + } + Tcl_DecrRefCount(returnOpts); + return; + } + } + TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); TclEmitInstInt4(op, code, envPtr); TclEmitInt4(level, envPtr); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 68b7649..427ccab 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3931,8 +3931,7 @@ TclEmitInvoke( va_list argList; ExceptionRange *rangePtr; ExceptionAux *auxBreakPtr, *auxContinuePtr; - int arg1, arg2, wordCount = 0, loopRange, predictedDepth; - int breakRange = -1, continueRange = -1; + int arg1, arg2, wordCount = 0, loopRange, breakRange, continueRange; /* * Parse the arguments. @@ -3995,7 +3994,6 @@ TclEmitInvoke( loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); ExceptionRangeStarts(envPtr, loopRange); } - predictedDepth = envPtr->currStackDepth - wordCount; /* * Issue the invoke itself. @@ -4047,7 +4045,6 @@ TclEmitInvoke( if (auxBreakPtr != NULL) { TclAdjustStackDepth(-1, envPtr); - assert(envPtr->currStackDepth == predictedDepth); exceptAux->stackDepth = auxBreakPtr->stackDepth; exceptAux->expandTarget = auxBreakPtr->expandTarget; @@ -4061,7 +4058,6 @@ TclEmitInvoke( if (auxContinuePtr != NULL) { TclAdjustStackDepth(-1, envPtr); - assert(envPtr->currStackDepth == predictedDepth); exceptAux->stackDepth = auxContinuePtr->stackDepth; exceptAux->expandTarget = auxContinuePtr->expandTarget; diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index b7f4173..3b16e6e 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -344,21 +344,28 @@ AdvanceJumps( CompileEnv *envPtr) { unsigned char *currentInstPtr; + Tcl_HashTable jumps; for (currentInstPtr = envPtr->codeStart ; currentInstPtr < envPtr->codeNext-1 ; currentInstPtr += AddrLength(currentInstPtr)) { - int offset, delta; + int offset, delta, isNew; switch (*currentInstPtr) { case INST_JUMP1: case INST_JUMP_TRUE1: case INST_JUMP_FALSE1: offset = TclGetInt1AtPtr(currentInstPtr + 1); + Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); for (delta=0 ; offset+delta != 0 ;) { if (offset + delta < -128 || offset + delta > 127) { break; } + Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); + if (!isNew) { + offset = TclGetInt1AtPtr(currentInstPtr + 1); + break; + } offset += delta; switch (*(currentInstPtr + offset)) { case INST_NOP: @@ -373,13 +380,21 @@ AdvanceJumps( } break; } + Tcl_DeleteHashTable(&jumps); TclStoreInt1AtPtr(offset, currentInstPtr + 1); continue; case INST_JUMP4: case INST_JUMP_TRUE4: case INST_JUMP_FALSE4: + Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); + Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew); for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) { + Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); + if (!isNew) { + offset = TclGetInt4AtPtr(currentInstPtr + 1); + break; + } switch (*(currentInstPtr + offset)) { case INST_NOP: offset += InstLength(INST_NOP); @@ -393,6 +408,7 @@ AdvanceJumps( } break; } + Tcl_DeleteHashTable(&jumps); TclStoreInt4AtPtr(offset, currentInstPtr + 1); continue; } diff --git a/tests/compile.test b/tests/compile.test index 51db0a2..36e24de 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -713,6 +713,70 @@ test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { apply {{} {list [if 1]}} } -returnCodes error -match glob -result * +test compile-20.1 {ensure there are no infinite loops in optimizing} { + tcl::unsupported::disassemble script { + while 1 { + return -code continue -level 0 + } + } + return +} {} +test compile-20.2 {ensure there are no infinite loops in optimizing} { + tcl::unsupported::disassemble script { + while 1 { + while 1 { + return -code break -level 0 + } + } + } + return +} {} + +test compile-21.1 {stack balance management} { + apply {{} { + set result {} + while 1 { + lappend result a + lappend result [list b [break]] + lappend result c + } + return $result + }} +} a +test compile-21.2 {stack balance management} { + apply {{} { + set result {} + while {[incr i] <= 10} { + lappend result $i + lappend result [list b [continue] c] + lappend result c + } + return $result + }} +} {1 2 3 4 5 6 7 8 9 10} +test compile-21.3 {stack balance management} { + apply {args { + set result {} + while 1 { + lappend result a + lappend result [concat {*}$args [break]] + lappend result c + } + return $result + }} P Q R S T +} a +test compile-21.4 {stack balance management} { + apply {args { + set result {} + while {[incr i] <= 10} { + lappend result $i + lappend result [concat {*}$args [continue] c] + lappend result c + } + return $result + }} P Q R S T +} {1 2 3 4 5 6 7 8 9 10} + # TODO sometime - check that bytecode from tbcload is *not* disassembled. # cleanup -- cgit v0.12 From d0041f33437e9af324059ed08c7f158fbb1fef19 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Oct 2013 21:09:19 +0000 Subject: -I${BUILD_DIR}/.. doesn't work when BUILD_DIR != "unix". Reported by Matthias Kraft --- unix/dltest/Makefile.in | 2 +- unix/dltest/pkgooa.c | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index f64b6d5..25b9376 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -22,7 +22,7 @@ LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ -CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -I${BUILD_DIR}/.. -DTCL_MEM_DEBUG \ +CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} pkgooa${SHLIB_SUFFIX} diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index 7b14ca0..78af376 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -11,7 +11,7 @@ */ #undef STATIC_BUILD -#include "tclOOInt.h" +#include "tclOO.h" #include /* @@ -64,6 +64,8 @@ Pkgooa_StubsOKObjCmd( *---------------------------------------------------------------------- */ +extern void *tclOOIntStubsPtr; + static TclOOStubs stubsCopy = { TCL_STUB_MAGIC, NULL, -- cgit v0.12 From 19365e8ffd408a387d99496423bd1d1ef04e492a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Oct 2013 09:28:11 +0000 Subject: Fix execute permission on many files which shouldn't have it. --- generic/tclStrToD.c | 0 library/encoding/tis-620.enc | 0 library/msgs/af.msg | 0 library/msgs/af_za.msg | 0 library/msgs/ar.msg | 0 library/msgs/ar_in.msg | 0 library/msgs/ar_jo.msg | 0 library/msgs/ar_lb.msg | 0 library/msgs/ar_sy.msg | 0 library/msgs/be.msg | 0 library/msgs/bg.msg | 0 library/msgs/bn.msg | 0 library/msgs/bn_in.msg | 0 library/msgs/ca.msg | 0 library/msgs/cs.msg | 0 library/msgs/da.msg | 0 library/msgs/de.msg | 0 library/msgs/de_at.msg | 0 library/msgs/de_be.msg | 0 library/msgs/el.msg | 0 library/msgs/en_au.msg | 0 library/msgs/en_be.msg | 0 library/msgs/en_bw.msg | 0 library/msgs/en_ca.msg | 0 library/msgs/en_gb.msg | 0 library/msgs/en_hk.msg | 0 library/msgs/en_ie.msg | 0 library/msgs/en_in.msg | 0 library/msgs/en_nz.msg | 0 library/msgs/en_ph.msg | 0 library/msgs/en_sg.msg | 0 library/msgs/en_za.msg | 0 library/msgs/en_zw.msg | 0 library/msgs/eo.msg | 0 library/msgs/es.msg | 0 library/msgs/es_ar.msg | 0 library/msgs/es_bo.msg | 0 library/msgs/es_cl.msg | 0 library/msgs/es_co.msg | 0 library/msgs/es_cr.msg | 0 library/msgs/es_do.msg | 0 library/msgs/es_ec.msg | 0 library/msgs/es_gt.msg | 0 library/msgs/es_hn.msg | 0 library/msgs/es_mx.msg | 0 library/msgs/es_ni.msg | 0 library/msgs/es_pa.msg | 0 library/msgs/es_pe.msg | 0 library/msgs/es_pr.msg | 0 library/msgs/es_py.msg | 0 library/msgs/es_sv.msg | 0 library/msgs/es_uy.msg | 0 library/msgs/es_ve.msg | 0 library/msgs/et.msg | 0 library/msgs/eu.msg | 0 library/msgs/eu_es.msg | 0 library/msgs/fa.msg | 0 library/msgs/fa_in.msg | 0 library/msgs/fa_ir.msg | 0 library/msgs/fi.msg | 0 library/msgs/fo.msg | 0 library/msgs/fo_fo.msg | 0 library/msgs/fr.msg | 0 library/msgs/fr_be.msg | 0 library/msgs/fr_ca.msg | 0 library/msgs/fr_ch.msg | 0 library/msgs/ga.msg | 0 library/msgs/ga_ie.msg | 0 library/msgs/gl.msg | 0 library/msgs/gl_es.msg | 0 library/msgs/gv.msg | 0 library/msgs/gv_gb.msg | 0 library/msgs/he.msg | 0 library/msgs/hi.msg | 0 library/msgs/hi_in.msg | 0 library/msgs/hr.msg | 0 library/msgs/hu.msg | 0 library/msgs/id.msg | 0 library/msgs/id_id.msg | 0 library/msgs/is.msg | 0 library/msgs/it.msg | 0 library/msgs/it_ch.msg | 0 library/msgs/ja.msg | 0 library/msgs/kl.msg | 0 library/msgs/kl_gl.msg | 0 library/msgs/ko.msg | 0 library/msgs/ko_kr.msg | 0 library/msgs/kok.msg | 0 library/msgs/kok_in.msg | 0 library/msgs/kw.msg | 0 library/msgs/kw_gb.msg | 0 library/msgs/lt.msg | 0 library/msgs/lv.msg | 0 library/msgs/mk.msg | 0 library/msgs/mr.msg | 0 library/msgs/mr_in.msg | 0 library/msgs/ms.msg | 0 library/msgs/ms_my.msg | 0 library/msgs/mt.msg | 0 library/msgs/nb.msg | 0 library/msgs/nl.msg | 0 library/msgs/nl_be.msg | 0 library/msgs/nn.msg | 0 library/msgs/pl.msg | 0 library/msgs/pt.msg | 0 library/msgs/pt_br.msg | 0 library/msgs/ro.msg | 0 library/msgs/ru.msg | 0 library/msgs/ru_ua.msg | 0 library/msgs/sh.msg | 0 library/msgs/sk.msg | 0 library/msgs/sl.msg | 0 library/msgs/sq.msg | 0 library/msgs/sr.msg | 0 library/msgs/sv.msg | 0 library/msgs/sw.msg | 0 library/msgs/ta.msg | 0 library/msgs/ta_in.msg | 0 library/msgs/te.msg | 0 library/msgs/te_in.msg | 0 library/msgs/th.msg | 0 library/msgs/tr.msg | 0 library/msgs/uk.msg | 0 library/msgs/vi.msg | 0 library/msgs/zh.msg | 0 library/msgs/zh_cn.msg | 0 library/msgs/zh_hk.msg | 0 library/msgs/zh_sg.msg | 0 library/msgs/zh_tw.msg | 0 library/tzdata/Africa/Asmara | 0 library/tzdata/America/Atikokan | 0 library/tzdata/America/Blanc-Sablon | 0 library/tzdata/America/Indiana/Petersburg | 0 library/tzdata/America/Indiana/Tell_City | 0 library/tzdata/America/Indiana/Vincennes | 0 library/tzdata/America/Indiana/Winamac | 0 library/tzdata/America/Moncton | 0 library/tzdata/America/North_Dakota/New_Salem | 0 library/tzdata/America/Resolute | 0 library/tzdata/Atlantic/Faroe | 0 library/tzdata/Australia/Eucla | 0 library/tzdata/Europe/Guernsey | 0 library/tzdata/Europe/Isle_of_Man | 0 library/tzdata/Europe/Jersey | 0 library/tzdata/Europe/Podgorica | 0 library/tzdata/Europe/Volgograd | 0 tools/encoding/ebcdic.txt | 0 tools/encoding/tis-620.txt | 0 148 files changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 generic/tclStrToD.c mode change 100755 => 100644 library/encoding/tis-620.enc mode change 100755 => 100644 library/msgs/af.msg mode change 100755 => 100644 library/msgs/af_za.msg mode change 100755 => 100644 library/msgs/ar.msg mode change 100755 => 100644 library/msgs/ar_in.msg mode change 100755 => 100644 library/msgs/ar_jo.msg mode change 100755 => 100644 library/msgs/ar_lb.msg mode change 100755 => 100644 library/msgs/ar_sy.msg mode change 100755 => 100644 library/msgs/be.msg mode change 100755 => 100644 library/msgs/bg.msg mode change 100755 => 100644 library/msgs/bn.msg mode change 100755 => 100644 library/msgs/bn_in.msg mode change 100755 => 100644 library/msgs/ca.msg mode change 100755 => 100644 library/msgs/cs.msg mode change 100755 => 100644 library/msgs/da.msg mode change 100755 => 100644 library/msgs/de.msg mode change 100755 => 100644 library/msgs/de_at.msg mode change 100755 => 100644 library/msgs/de_be.msg mode change 100755 => 100644 library/msgs/el.msg mode change 100755 => 100644 library/msgs/en_au.msg mode change 100755 => 100644 library/msgs/en_be.msg mode change 100755 => 100644 library/msgs/en_bw.msg mode change 100755 => 100644 library/msgs/en_ca.msg mode change 100755 => 100644 library/msgs/en_gb.msg mode change 100755 => 100644 library/msgs/en_hk.msg mode change 100755 => 100644 library/msgs/en_ie.msg mode change 100755 => 100644 library/msgs/en_in.msg mode change 100755 => 100644 library/msgs/en_nz.msg mode change 100755 => 100644 library/msgs/en_ph.msg mode change 100755 => 100644 library/msgs/en_sg.msg mode change 100755 => 100644 library/msgs/en_za.msg mode change 100755 => 100644 library/msgs/en_zw.msg mode change 100755 => 100644 library/msgs/eo.msg mode change 100755 => 100644 library/msgs/es.msg mode change 100755 => 100644 library/msgs/es_ar.msg mode change 100755 => 100644 library/msgs/es_bo.msg mode change 100755 => 100644 library/msgs/es_cl.msg mode change 100755 => 100644 library/msgs/es_co.msg mode change 100755 => 100644 library/msgs/es_cr.msg mode change 100755 => 100644 library/msgs/es_do.msg mode change 100755 => 100644 library/msgs/es_ec.msg mode change 100755 => 100644 library/msgs/es_gt.msg mode change 100755 => 100644 library/msgs/es_hn.msg mode change 100755 => 100644 library/msgs/es_mx.msg mode change 100755 => 100644 library/msgs/es_ni.msg mode change 100755 => 100644 library/msgs/es_pa.msg mode change 100755 => 100644 library/msgs/es_pe.msg mode change 100755 => 100644 library/msgs/es_pr.msg mode change 100755 => 100644 library/msgs/es_py.msg mode change 100755 => 100644 library/msgs/es_sv.msg mode change 100755 => 100644 library/msgs/es_uy.msg mode change 100755 => 100644 library/msgs/es_ve.msg mode change 100755 => 100644 library/msgs/et.msg mode change 100755 => 100644 library/msgs/eu.msg mode change 100755 => 100644 library/msgs/eu_es.msg mode change 100755 => 100644 library/msgs/fa.msg mode change 100755 => 100644 library/msgs/fa_in.msg mode change 100755 => 100644 library/msgs/fa_ir.msg mode change 100755 => 100644 library/msgs/fi.msg mode change 100755 => 100644 library/msgs/fo.msg mode change 100755 => 100644 library/msgs/fo_fo.msg mode change 100755 => 100644 library/msgs/fr.msg mode change 100755 => 100644 library/msgs/fr_be.msg mode change 100755 => 100644 library/msgs/fr_ca.msg mode change 100755 => 100644 library/msgs/fr_ch.msg mode change 100755 => 100644 library/msgs/ga.msg mode change 100755 => 100644 library/msgs/ga_ie.msg mode change 100755 => 100644 library/msgs/gl.msg mode change 100755 => 100644 library/msgs/gl_es.msg mode change 100755 => 100644 library/msgs/gv.msg mode change 100755 => 100644 library/msgs/gv_gb.msg mode change 100755 => 100644 library/msgs/he.msg mode change 100755 => 100644 library/msgs/hi.msg mode change 100755 => 100644 library/msgs/hi_in.msg mode change 100755 => 100644 library/msgs/hr.msg mode change 100755 => 100644 library/msgs/hu.msg mode change 100755 => 100644 library/msgs/id.msg mode change 100755 => 100644 library/msgs/id_id.msg mode change 100755 => 100644 library/msgs/is.msg mode change 100755 => 100644 library/msgs/it.msg mode change 100755 => 100644 library/msgs/it_ch.msg mode change 100755 => 100644 library/msgs/ja.msg mode change 100755 => 100644 library/msgs/kl.msg mode change 100755 => 100644 library/msgs/kl_gl.msg mode change 100755 => 100644 library/msgs/ko.msg mode change 100755 => 100644 library/msgs/ko_kr.msg mode change 100755 => 100644 library/msgs/kok.msg mode change 100755 => 100644 library/msgs/kok_in.msg mode change 100755 => 100644 library/msgs/kw.msg mode change 100755 => 100644 library/msgs/kw_gb.msg mode change 100755 => 100644 library/msgs/lt.msg mode change 100755 => 100644 library/msgs/lv.msg mode change 100755 => 100644 library/msgs/mk.msg mode change 100755 => 100644 library/msgs/mr.msg mode change 100755 => 100644 library/msgs/mr_in.msg mode change 100755 => 100644 library/msgs/ms.msg mode change 100755 => 100644 library/msgs/ms_my.msg mode change 100755 => 100644 library/msgs/mt.msg mode change 100755 => 100644 library/msgs/nb.msg mode change 100755 => 100644 library/msgs/nl.msg mode change 100755 => 100644 library/msgs/nl_be.msg mode change 100755 => 100644 library/msgs/nn.msg mode change 100755 => 100644 library/msgs/pl.msg mode change 100755 => 100644 library/msgs/pt.msg mode change 100755 => 100644 library/msgs/pt_br.msg mode change 100755 => 100644 library/msgs/ro.msg mode change 100755 => 100644 library/msgs/ru.msg mode change 100755 => 100644 library/msgs/ru_ua.msg mode change 100755 => 100644 library/msgs/sh.msg mode change 100755 => 100644 library/msgs/sk.msg mode change 100755 => 100644 library/msgs/sl.msg mode change 100755 => 100644 library/msgs/sq.msg mode change 100755 => 100644 library/msgs/sr.msg mode change 100755 => 100644 library/msgs/sv.msg mode change 100755 => 100644 library/msgs/sw.msg mode change 100755 => 100644 library/msgs/ta.msg mode change 100755 => 100644 library/msgs/ta_in.msg mode change 100755 => 100644 library/msgs/te.msg mode change 100755 => 100644 library/msgs/te_in.msg mode change 100755 => 100644 library/msgs/th.msg mode change 100755 => 100644 library/msgs/tr.msg mode change 100755 => 100644 library/msgs/uk.msg mode change 100755 => 100644 library/msgs/vi.msg mode change 100755 => 100644 library/msgs/zh.msg mode change 100755 => 100644 library/msgs/zh_cn.msg mode change 100755 => 100644 library/msgs/zh_hk.msg mode change 100755 => 100644 library/msgs/zh_sg.msg mode change 100755 => 100644 library/msgs/zh_tw.msg mode change 100755 => 100644 library/tzdata/Africa/Asmara mode change 100755 => 100644 library/tzdata/America/Atikokan mode change 100755 => 100644 library/tzdata/America/Blanc-Sablon mode change 100755 => 100644 library/tzdata/America/Indiana/Petersburg mode change 100755 => 100644 library/tzdata/America/Indiana/Tell_City mode change 100755 => 100644 library/tzdata/America/Indiana/Vincennes mode change 100755 => 100644 library/tzdata/America/Indiana/Winamac mode change 100755 => 100644 library/tzdata/America/Moncton mode change 100755 => 100644 library/tzdata/America/North_Dakota/New_Salem mode change 100755 => 100644 library/tzdata/America/Resolute mode change 100755 => 100644 library/tzdata/Atlantic/Faroe mode change 100755 => 100644 library/tzdata/Australia/Eucla mode change 100755 => 100644 library/tzdata/Europe/Guernsey mode change 100755 => 100644 library/tzdata/Europe/Isle_of_Man mode change 100755 => 100644 library/tzdata/Europe/Jersey mode change 100755 => 100644 library/tzdata/Europe/Podgorica mode change 100755 => 100644 library/tzdata/Europe/Volgograd mode change 100755 => 100644 tools/encoding/ebcdic.txt mode change 100755 => 100644 tools/encoding/tis-620.txt diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c old mode 100755 new mode 100644 diff --git a/library/encoding/tis-620.enc b/library/encoding/tis-620.enc old mode 100755 new mode 100644 diff --git a/library/msgs/af.msg b/library/msgs/af.msg old mode 100755 new mode 100644 diff --git a/library/msgs/af_za.msg b/library/msgs/af_za.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar.msg b/library/msgs/ar.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_in.msg b/library/msgs/ar_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_jo.msg b/library/msgs/ar_jo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_lb.msg b/library/msgs/ar_lb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_sy.msg b/library/msgs/ar_sy.msg old mode 100755 new mode 100644 diff --git a/library/msgs/be.msg b/library/msgs/be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/bg.msg b/library/msgs/bg.msg old mode 100755 new mode 100644 diff --git a/library/msgs/bn.msg b/library/msgs/bn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/bn_in.msg b/library/msgs/bn_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ca.msg b/library/msgs/ca.msg old mode 100755 new mode 100644 diff --git a/library/msgs/cs.msg b/library/msgs/cs.msg old mode 100755 new mode 100644 diff --git a/library/msgs/da.msg b/library/msgs/da.msg old mode 100755 new mode 100644 diff --git a/library/msgs/de.msg b/library/msgs/de.msg old mode 100755 new mode 100644 diff --git a/library/msgs/de_at.msg b/library/msgs/de_at.msg old mode 100755 new mode 100644 diff --git a/library/msgs/de_be.msg b/library/msgs/de_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/el.msg b/library/msgs/el.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_au.msg b/library/msgs/en_au.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_be.msg b/library/msgs/en_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_bw.msg b/library/msgs/en_bw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_ca.msg b/library/msgs/en_ca.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_gb.msg b/library/msgs/en_gb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_hk.msg b/library/msgs/en_hk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_ie.msg b/library/msgs/en_ie.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_in.msg b/library/msgs/en_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_nz.msg b/library/msgs/en_nz.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_ph.msg b/library/msgs/en_ph.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_sg.msg b/library/msgs/en_sg.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_za.msg b/library/msgs/en_za.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_zw.msg b/library/msgs/en_zw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/eo.msg b/library/msgs/eo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es.msg b/library/msgs/es.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ar.msg b/library/msgs/es_ar.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_bo.msg b/library/msgs/es_bo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_cl.msg b/library/msgs/es_cl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_co.msg b/library/msgs/es_co.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_cr.msg b/library/msgs/es_cr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_do.msg b/library/msgs/es_do.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ec.msg b/library/msgs/es_ec.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_gt.msg b/library/msgs/es_gt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_hn.msg b/library/msgs/es_hn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_mx.msg b/library/msgs/es_mx.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ni.msg b/library/msgs/es_ni.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_pa.msg b/library/msgs/es_pa.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_pe.msg b/library/msgs/es_pe.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_pr.msg b/library/msgs/es_pr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_py.msg b/library/msgs/es_py.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_sv.msg b/library/msgs/es_sv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_uy.msg b/library/msgs/es_uy.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ve.msg b/library/msgs/es_ve.msg old mode 100755 new mode 100644 diff --git a/library/msgs/et.msg b/library/msgs/et.msg old mode 100755 new mode 100644 diff --git a/library/msgs/eu.msg b/library/msgs/eu.msg old mode 100755 new mode 100644 diff --git a/library/msgs/eu_es.msg b/library/msgs/eu_es.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fa.msg b/library/msgs/fa.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fa_in.msg b/library/msgs/fa_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fa_ir.msg b/library/msgs/fa_ir.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fi.msg b/library/msgs/fi.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fo.msg b/library/msgs/fo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fo_fo.msg b/library/msgs/fo_fo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr.msg b/library/msgs/fr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr_be.msg b/library/msgs/fr_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr_ca.msg b/library/msgs/fr_ca.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr_ch.msg b/library/msgs/fr_ch.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ga.msg b/library/msgs/ga.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ga_ie.msg b/library/msgs/ga_ie.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gl.msg b/library/msgs/gl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gl_es.msg b/library/msgs/gl_es.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gv.msg b/library/msgs/gv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gv_gb.msg b/library/msgs/gv_gb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/he.msg b/library/msgs/he.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hi.msg b/library/msgs/hi.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hi_in.msg b/library/msgs/hi_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hr.msg b/library/msgs/hr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hu.msg b/library/msgs/hu.msg old mode 100755 new mode 100644 diff --git a/library/msgs/id.msg b/library/msgs/id.msg old mode 100755 new mode 100644 diff --git a/library/msgs/id_id.msg b/library/msgs/id_id.msg old mode 100755 new mode 100644 diff --git a/library/msgs/is.msg b/library/msgs/is.msg old mode 100755 new mode 100644 diff --git a/library/msgs/it.msg b/library/msgs/it.msg old mode 100755 new mode 100644 diff --git a/library/msgs/it_ch.msg b/library/msgs/it_ch.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ja.msg b/library/msgs/ja.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kl.msg b/library/msgs/kl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kl_gl.msg b/library/msgs/kl_gl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ko.msg b/library/msgs/ko.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ko_kr.msg b/library/msgs/ko_kr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kok.msg b/library/msgs/kok.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kok_in.msg b/library/msgs/kok_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kw.msg b/library/msgs/kw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kw_gb.msg b/library/msgs/kw_gb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/lt.msg b/library/msgs/lt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/lv.msg b/library/msgs/lv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mk.msg b/library/msgs/mk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mr.msg b/library/msgs/mr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mr_in.msg b/library/msgs/mr_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ms.msg b/library/msgs/ms.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ms_my.msg b/library/msgs/ms_my.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mt.msg b/library/msgs/mt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nb.msg b/library/msgs/nb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nl.msg b/library/msgs/nl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nl_be.msg b/library/msgs/nl_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nn.msg b/library/msgs/nn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/pl.msg b/library/msgs/pl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/pt.msg b/library/msgs/pt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/pt_br.msg b/library/msgs/pt_br.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ro.msg b/library/msgs/ro.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ru.msg b/library/msgs/ru.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ru_ua.msg b/library/msgs/ru_ua.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sh.msg b/library/msgs/sh.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sk.msg b/library/msgs/sk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sl.msg b/library/msgs/sl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sq.msg b/library/msgs/sq.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sr.msg b/library/msgs/sr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sv.msg b/library/msgs/sv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sw.msg b/library/msgs/sw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ta.msg b/library/msgs/ta.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ta_in.msg b/library/msgs/ta_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/te.msg b/library/msgs/te.msg old mode 100755 new mode 100644 diff --git a/library/msgs/te_in.msg b/library/msgs/te_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/th.msg b/library/msgs/th.msg old mode 100755 new mode 100644 diff --git a/library/msgs/tr.msg b/library/msgs/tr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/uk.msg b/library/msgs/uk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/vi.msg b/library/msgs/vi.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh.msg b/library/msgs/zh.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_cn.msg b/library/msgs/zh_cn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_hk.msg b/library/msgs/zh_hk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_sg.msg b/library/msgs/zh_sg.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_tw.msg b/library/msgs/zh_tw.msg old mode 100755 new mode 100644 diff --git a/library/tzdata/Africa/Asmara b/library/tzdata/Africa/Asmara old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Atikokan b/library/tzdata/America/Atikokan old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Blanc-Sablon b/library/tzdata/America/Blanc-Sablon old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Petersburg b/library/tzdata/America/Indiana/Petersburg old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Tell_City b/library/tzdata/America/Indiana/Tell_City old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Vincennes b/library/tzdata/America/Indiana/Vincennes old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Winamac b/library/tzdata/America/Indiana/Winamac old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Moncton b/library/tzdata/America/Moncton old mode 100755 new mode 100644 diff --git a/library/tzdata/America/North_Dakota/New_Salem b/library/tzdata/America/North_Dakota/New_Salem old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Resolute b/library/tzdata/America/Resolute old mode 100755 new mode 100644 diff --git a/library/tzdata/Atlantic/Faroe b/library/tzdata/Atlantic/Faroe old mode 100755 new mode 100644 diff --git a/library/tzdata/Australia/Eucla b/library/tzdata/Australia/Eucla old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Guernsey b/library/tzdata/Europe/Guernsey old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Isle_of_Man b/library/tzdata/Europe/Isle_of_Man old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Jersey b/library/tzdata/Europe/Jersey old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Podgorica b/library/tzdata/Europe/Podgorica old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Volgograd b/library/tzdata/Europe/Volgograd old mode 100755 new mode 100644 diff --git a/tools/encoding/ebcdic.txt b/tools/encoding/ebcdic.txt old mode 100755 new mode 100644 diff --git a/tools/encoding/tis-620.txt b/tools/encoding/tis-620.txt old mode 100755 new mode 100644 -- cgit v0.12 From d936bf460871729ab8f1b2972bb85a1c679fe9d9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Oct 2013 11:22:47 +0000 Subject: Prevent tclOOIntStubs from being exported from the shared library. --- generic/tclOODecls.h | 1 + generic/tclOOStubInit.c | 1 + 2 files changed, 2 insertions(+) diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 1ddb7c6..b93865e 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -11,6 +11,7 @@ #endif #define tclOOPrivateStubs tclOOIntStubs +#define TclOOPrivateStubs TclOOIntStubs /* !BEGIN!: Do not edit below this line. */ diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index 33da395..7be341a 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -9,6 +9,7 @@ #include "tclOOInt.h" MODULE_SCOPE const TclOOStubs tclOOStubs; +MODULE_SCOPE const TclOOIntStubs tclOOIntStubs; #ifdef __GNUC__ #pragma GCC dependency "tclOO.decls" -- cgit v0.12 From c00bdffb6aa0fca3575ef0ab1a07813f696f1839 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 18 Oct 2013 07:08:46 +0000 Subject: Tackle evalStk by reusing existing machinery. --- generic/tclCompCmds.c | 2 +- generic/tclCompile.c | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 942d74c..25201eb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -620,7 +620,7 @@ TclCompileCatchCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_EVAL_STK, envPtr); + TclEmitInvoke(envPtr, INST_EVAL_STK); } /* Stack at this point: * nonsimple: script result diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 427ccab..f91c2fd 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2458,7 +2458,7 @@ TclCompileCmdWord( */ TclCompileTokens(interp, tokenPtr, count, envPtr); - TclEmitOpcode(INST_EVAL_STK, envPtr); + TclEmitInvoke(envPtr, INST_EVAL_STK); } } @@ -3954,6 +3954,7 @@ TclEmitInvoke( break; default: Tcl_Panic("unexpected opcode"); + case INST_EVAL_STK: case INST_INVOKE_EXPANDED: wordCount = arg1 = arg2 = 0; break; @@ -4009,6 +4010,9 @@ TclEmitInvoke( case INST_INVOKE_EXPANDED: TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); break; + case INST_EVAL_STK: + TclEmitOpcode(INST_EVAL_STK, envPtr); + break; case INST_INVOKE_REPLACE: TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); TclEmitInt1(arg2, envPtr); -- cgit v0.12 From 3e798bfe4700fd510a0daf3944429c75596786da Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 19 Oct 2013 11:20:46 +0000 Subject: Improve coverage of [error] compilation. --- generic/tclCompCmds.c | 43 ++++++++++++++++++++++++++++++++++++------- 1 file changed, 36 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 25201eb..c55635a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2135,19 +2135,48 @@ TclCompileErrorCmd( { /* * General syntax: [error message ?errorInfo? ?errorCode?] - * However, we only deal with the case where there is just a message. */ - Tcl_Token *messageTokenPtr; + + Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ - if (parsePtr->numWords != 2) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { return TCL_ERROR; } - messageTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushStringLiteral(envPtr, "-code error -level 0"); - CompileWord(envPtr, messageTokenPtr, interp, 1); - TclEmitOpcode(INST_RETURN_STK, envPtr); + /* + * Handle the message. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Construct the options. Note that -code and -level are not here. + */ + + if (parsePtr->numWords == 2) { + PushStringLiteral(envPtr, ""); + } else { + PushStringLiteral(envPtr, "-errorinfo"); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + if (parsePtr->numWords == 3) { + TclEmitInstInt4( INST_LIST, 2, envPtr); + } else { + PushStringLiteral(envPtr, "-errorcode"); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + TclEmitInstInt4( INST_LIST, 4, envPtr); + } + } + + /* + * Issue the error via 'returnImm error 0'. + */ + + TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr); + TclEmitInt4( 0, envPtr); return TCL_OK; } -- cgit v0.12 From 674d5acbcfa7bfb12b407c88bd4bf67ae1b1d0ac Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 19 Oct 2013 12:29:06 +0000 Subject: Added missing exception range finalize. --- generic/tclCompile.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f91c2fd..89b9011 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -4073,6 +4073,7 @@ TclEmitInvoke( envPtr->expandCount = savedExpandCount; } + TclFinalizeLoopExceptionRange(envPtr, loopRange); TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); } } -- cgit v0.12 From acfb2a50369dae9afcf444519e5d3875812d5a3b Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 19 Oct 2013 14:11:28 +0000 Subject: Fix handling of 'invokeExpanded' and start to do 'returnStk'. --- generic/tclCompCmdsGR.c | 4 +- generic/tclCompile.c | 27 ++++++++--- tests/for.test | 116 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 138 insertions(+), 9 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 5513b01..fbd370b 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2367,7 +2367,7 @@ TclCompileReturnCmd( CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); - TclEmitOpcode(INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); return TCL_OK; } @@ -2509,7 +2509,7 @@ TclCompileReturnCmd( * Issue the RETURN itself. */ - TclEmitOpcode(INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 89b9011..ae6e56c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1802,9 +1802,7 @@ CompileExpanded( * stack-neutral in general. */ - TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED); - envPtr->expandCount--; - TclAdjustStackDepth(1 - wordIdx, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); } static int @@ -3931,7 +3929,8 @@ TclEmitInvoke( va_list argList; ExceptionRange *rangePtr; ExceptionAux *auxBreakPtr, *auxContinuePtr; - int arg1, arg2, wordCount = 0, loopRange, breakRange, continueRange; + int arg1, arg2, wordCount = 0, expandCount = 0; + int loopRange, breakRange, continueRange; /* * Parse the arguments. @@ -3955,8 +3954,17 @@ TclEmitInvoke( default: Tcl_Panic("unexpected opcode"); case INST_EVAL_STK: + wordCount = 1; + arg1 = arg2 = 0; + break; + case INST_RETURN_STK: + wordCount = 2; + arg1 = arg2 = 0; + break; case INST_INVOKE_EXPANDED: - wordCount = arg1 = arg2 = 0; + wordCount = arg1 = va_arg(argList, int); + arg2 = 0; + expandCount = 1; break; } va_end(argList); @@ -3974,7 +3982,7 @@ TclEmitInvoke( if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { auxBreakPtr = NULL; } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount - && auxBreakPtr->expandTarget == envPtr->expandCount) { + && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) { auxBreakPtr = NULL; } else { breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; @@ -3985,7 +3993,7 @@ TclEmitInvoke( if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { auxContinuePtr = NULL; } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount - && auxContinuePtr->expandTarget == envPtr->expandCount) { + && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) { auxContinuePtr = NULL; } else { continueRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; @@ -4009,10 +4017,15 @@ TclEmitInvoke( break; case INST_INVOKE_EXPANDED: TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - arg1, envPtr); break; case INST_EVAL_STK: TclEmitOpcode(INST_EVAL_STK, envPtr); break; + case INST_RETURN_STK: + TclEmitOpcode(INST_RETURN_STK, envPtr); + break; case INST_INVOKE_REPLACE: TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); TclEmitInt1(arg2, envPtr); diff --git a/tests/for.test b/tests/for.test index 6a18abe..8abd270 100644 --- a/tests/for.test +++ b/tests/for.test @@ -1068,6 +1068,122 @@ test for-7.16 {Bug 3614226: ensure that continue from invoked command only clean expr {$end - $tmp} }} } 0 +test for-7.17 {Bug 3614226: ensure that break from expanded command cleans up the stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [{*}$op] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.18 {Bug 3614226: ensure that continue from expanded command cleans up the stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [{*}$op] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.19 {Bug 3614226: ensure that break from expanded command cleans up the expansion stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[{*}$op] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.20 {Bug 3614226: ensure that continue from expanded command cleans up the expansion stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[{*}$op] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.21 {Bug 3614226: ensure that break from expanded command cleans up the combination of main and expansion stack} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.22 {Bug 3614226: ensure that continue from expanded command cleans up the combination of main and expansion stack} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.23 {Bug 3614226: ensure that break from expanded command only cleans up the right amount} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.24 {Bug 3614226: ensure that continue from expanded command only cleans up the right amount} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 39e314ad912cdbd29ba3e01673b1097b40118f8b Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 20 Oct 2013 18:11:35 +0000 Subject: And the last bits that need fixing; the code is still less efficient than desired but should now not crash. --- generic/tclAssembly.c | 35 +++++++++++++++++++++++++++++++---- generic/tclCompCmds.c | 4 ++-- generic/tclCompCmdsGR.c | 6 +++++- generic/tclCompCmdsSZ.c | 12 +++++++----- 4 files changed, 45 insertions(+), 12 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 08da075..fc51457 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -246,6 +246,8 @@ 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); @@ -679,10 +681,13 @@ BBEmitInstInt4( /* *----------------------------------------------------------------------------- * - * BBEmitInst1or4 -- + * BBEmitInst1or4, BBEmitInvoke1or4 -- * * Emits a 1- or 4-byte operation according to the magnitude of the - * operand + * 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). * *----------------------------------------------------------------------------- */ @@ -714,6 +719,29 @@ 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); +} /* *----------------------------------------------------------------------------- @@ -1450,8 +1478,7 @@ AssembleOneLine( goto cleanup; } - // FIXME - use TclEmitInvoke - BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); + BBEmitInvoke1or4(assemEnvPtr, tblIdx, opnd, opnd); break; case ASSEM_JUMP: diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c55635a..9c43bfe 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1675,7 +1675,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr,INST_RETURN_STK); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", @@ -2033,7 +2033,7 @@ TclCompileDictWithCmd( } else { TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); } - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); /* * Prepare for the start of the next command. diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index fbd370b..d00327d 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2381,6 +2381,10 @@ TclCompileReturnCmd( * Scan through the return options. If any are unknown at compile time, * there is no value in bytecompiling. Save the option values known in an * objv array for merging into a return options dictionary. + * + * TODO: There is potential for improvement if all option keys are known + * at compile time and all option values relating to '-code' and '-level' + * are known at compile time. */ for (objc = 0; objc < numOptionWords; objc++) { @@ -2388,7 +2392,7 @@ TclCompileReturnCmd( Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { /* - * Non-literal, so punt to run-time. + * Non-literal, so punt to run-time assembly of the dictionary. */ for (; objc>=0 ; objc--) { diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index a5ec731..754238f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -99,6 +99,8 @@ const AuxDataType tclJumptableInfoType = { if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} #define STORE(idx) \ if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} +#define INVOKE(name) \ + TclEmitInvoke(envPtr,INST_##name) /* *---------------------------------------------------------------------- @@ -873,7 +875,7 @@ TclSubstCompile( OP( END_CATCH); OP( RETURN_CODE_BRANCH); - /* ERROR -> reraise it */ + /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ OP( RETURN_STK); OP( NOP); @@ -2396,7 +2398,7 @@ IssueTryClausesInstructions( TclAdjustStackDepth(-1, envPtr); FIXJUMP1( dontChangeOptions); OP4( REVERSE, 2); - OP( RETURN_STK); + INVOKE( RETURN_STK); } JUMP4( JUMP, addrsToFix[i]); @@ -2415,7 +2417,7 @@ IssueTryClausesInstructions( OP( POP); LOAD( optionsVar); LOAD( resultVar); - OP( RETURN_STK); + INVOKE( RETURN_STK); /* * Fix all the jumps from taken clauses to here (which is the end of the @@ -2724,7 +2726,7 @@ IssueTryClausesFinallyInstructions( FIXJUMP1( finalOK); LOAD( optionsVar); LOAD( resultVar); - OP( RETURN_STK); + INVOKE( RETURN_STK); return TCL_OK; } @@ -2783,7 +2785,7 @@ IssueTryFinallyInstructions( OP1( JUMP1, 7); FIXJUMP1( jumpOK); OP4( REVERSE, 2); - OP( RETURN_STK); + INVOKE( RETURN_STK); return TCL_OK; } -- cgit v0.12 From 30cd4b442c047d01653b1c217b0364eb6b5c8101 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 21 Oct 2013 14:35:02 +0000 Subject: silence compiler warnings --- generic/tclCompile.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ae6e56c..a150fc2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3930,7 +3930,7 @@ TclEmitInvoke( ExceptionRange *rangePtr; ExceptionAux *auxBreakPtr, *auxContinuePtr; int arg1, arg2, wordCount = 0, expandCount = 0; - int loopRange, breakRange, continueRange; + int loopRange = 0, breakRange = 0, continueRange = 0; /* * Parse the arguments. -- cgit v0.12 From fff622bfb179b6e2fb8d95991ae911a0f056774d 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 545698c7c06b1e3d1956d77508ecaf251163fb22 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 Oct 2013 14:29:03 +0000 Subject: Fix problems in for.test --- generic/tclCompile.c | 136 +++++++++++++++++++++++---------------------------- 1 file changed, 62 insertions(+), 74 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a150fc2..dcd74f1 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1755,7 +1755,6 @@ CompileExpanded( int wordIdx = 0; DefineLineInformation; - StartExpanding(envPtr); if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -1787,19 +1786,17 @@ CompileExpanded( } /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. + * The stack depth during argument expansion can only be managed at + * runtime, as the number of elements in the expanded lists is not known + * at compile time. We adjust here the stack depth estimate so that it is + * correct after the command with expanded arguments returns. * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). + * The end effect of this command's invocation is that all the words of + * the command are popped from the stack, and the result is pushed: the + * stack top changes by (1-wordIdx). * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. + * Note that the estimates are not correct while the command is being + * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general. */ TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); @@ -1816,8 +1813,8 @@ CompileCmdCompileProc( DefineLineInformation; /* - * Emit of the INST_START_CMD instruction is controlled by - * the value of envPtr->atCmdStart: + * Emit of the INST_START_CMD instruction is controlled by the value of + * envPtr->atCmdStart: * * atCmdStart == 2 : We are not using the INST_START_CMD instruction. * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. @@ -1848,9 +1845,10 @@ CompileCmdCompileProc( if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { if (incrOffset >= 0) { /* - * We successfully compiled a command. Increment the number - * of commands that start at the currently active INST_START_CMD. + * We successfully compiled a command. Increment the number of + * commands that start at the currently active INST_START_CMD. */ + unsigned char *incrPtr = envPtr->codeStart + incrOffset; unsigned char *startPtr = incrPtr - 5; @@ -1866,9 +1864,9 @@ CompileCmdCompileProc( envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ /* - * Throw out any line information generated by the failed - * compile attempt. + * Throw out any line information generated by the failed compile attempt. */ + while (mapPtr->nuloc - 1 > eclIndex) { mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); @@ -1876,11 +1874,11 @@ CompileCmdCompileProc( } /* - * Reset the index of next command. - * Toss out any from failed nested partial compiles. + * Reset the index of next command. Toss out any from failed nested + * partial compiles. */ - envPtr->numCommands = mapPtr->nuloc; + envPtr->numCommands = mapPtr->nuloc; return TCL_ERROR; } @@ -1912,11 +1910,10 @@ CompileCommandTokens( parsePtr->commandStart - envPtr->source, startCodeOffset); /* - * TIP #280. Scan the words and compute the extended location - * information. The map first contain full per-word line - * information for use by the compiler. This is later replaced by - * a reduced form which signals non-literal words, stored in - * 'wlines'. + * TIP #280. Scan the words and compute the extended location information. + * The map first contain full per-word line information for use by the + * compiler. This is later replaced by a reduced form which signals + * non-literal words, stored in 'wlines'. */ EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, @@ -1938,8 +1935,8 @@ CompileCommandTokens( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if (cmdPtr) { /* - * Found a command. Test the ways we can be told - * not to attempt to compile it. + * Found a command. Test the ways we can be told not to attempt + * to compile it. */ if ((cmdPtr->compileProc == NULL) || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) @@ -1983,8 +1980,8 @@ CompileCommandTokens( (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); /* - * TIP #280: Free full form of per-word line data and insert the - * reduced form now + * TIP #280: Free full form of per-word line data and insert the reduced + * form now */ envPtr->line = cmdLine; @@ -2069,20 +2066,20 @@ TclCompileScript( if (parse.numWords == 0) { /* - * The "command" parsed has no words. In this case - * we can skip the rest of the loop body. With no words, - * clearly CompileCommandTokens() has nothing to do. Since - * the parser aggressively sucks up leading comment and white - * space, including newlines, parse.commandStart must be - * pointing at either the end of script, or a command-terminating - * semi-colon. In either case, the TclAdvance*() calls have - * nothing to do. Finally, when no words are parsed, no - * tokens have been allocated at parse.tokenPtr so there's - * also nothing for Tcl_FreeParse() to do. + * The "command" parsed has no words. In this case we can skip + * the rest of the loop body. With no words, clearly + * CompileCommandTokens() has nothing to do. Since the parser + * aggressively sucks up leading comment and white space, + * including newlines, parse.commandStart must be pointing at + * either the end of script, or a command-terminating semi-colon. + * In either case, the TclAdvance*() calls have nothing to do. + * Finally, when no words are parsed, no tokens have been + * allocated at parse.tokenPtr so there's also nothing for + * Tcl_FreeParse() to do. * * The advantage of this shortcut is that CompileCommandTokens() - * can be written with an assumption that parse.numWords > 0, - * with the implication the CCT() always generates bytecode. + * can be written with an assumption that parse.numWords > 0, with + * the implication the CCT() always generates bytecode. */ continue; } @@ -2101,23 +2098,25 @@ TclCompileScript( if (lastCmdIdx == -1) { /* - * Compiling the script yielded no bytecode. The script must be - * all whitespace, comments, and empty commands. Such scripts - * are defined to successfully produce the empty string result, - * so we emit the simple bytecode that makes that happen. + * Compiling the script yielded no bytecode. The script must be all + * whitespace, comments, and empty commands. Such scripts are defined + * to successfully produce the empty string result, so we emit the + * simple bytecode that makes that happen. */ + PushStringLiteral(envPtr, ""); } else { /* * We compiled at least one command to bytecode. The routine * CompileCommandTokens() follows the bytecode of each compiled - * command with an INST_POP, so that stack balance is maintained - * when several commands are in sequence. (The result of each - * command is thrown away before moving on to the next command). - * For the last command compiled, we need to undo that INST_POP - * so that the result of the last command becomes the result of - * the script. The code here removes that trailing INST_POP. + * command with an INST_POP, so that stack balance is maintained when + * several commands are in sequence. (The result of each command is + * thrown away before moving on to the next command). For the last + * command compiled, we need to undo that INST_POP so that the result + * of the last command becomes the result of the script. The code + * here removes that trailing INST_POP. */ + envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; envPtr->currStackDepth++; @@ -3353,9 +3352,9 @@ TclAddLoopContinueFixup( * * TclCleanupStackForBreakContinue -- * - * Ditch the extra elements from the auxiliary stack and the main - * stack. How to do this exactly depends on whether there are any - * elements on the auxiliary stack to pop. + * Ditch the extra elements from the auxiliary stack and the main stack. + * How to do this exactly depends on whether there are any elements on + * the auxiliary stack to pop. * * --------------------------------------------------------------------- */ @@ -3369,23 +3368,16 @@ TclCleanupStackForBreakContinue( int toPop = envPtr->expandCount - auxPtr->expandTarget; if (toPop > 0) { - while (toPop > 0) { + while (toPop --> 0) { TclEmitOpcode(INST_EXPAND_DROP, envPtr); - toPop--; } TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, envPtr); - toPop = auxPtr->expandTargetDepth - auxPtr->stackDepth; - while (toPop > 0) { - TclEmitOpcode(INST_POP, envPtr); - toPop--; - } - } else { - toPop = envPtr->currStackDepth - auxPtr->stackDepth; - while (toPop > 0) { - TclEmitOpcode(INST_POP, envPtr); - toPop--; - } + envPtr->currStackDepth = auxPtr->expandTargetDepth; + } + toPop = envPtr->currStackDepth - auxPtr->stackDepth; + while (toPop --> 0) { + TclEmitOpcode(INST_POP, envPtr); } envPtr->currStackDepth = savedStackDepth; } @@ -4062,11 +4054,9 @@ TclEmitInvoke( if (auxBreakPtr != NULL) { TclAdjustStackDepth(-1, envPtr); - exceptAux->stackDepth = auxBreakPtr->stackDepth; - exceptAux->expandTarget = auxBreakPtr->expandTarget; ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclCleanupStackForBreakContinue(envPtr, exceptAux); + TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); TclAddLoopBreakFixup(envPtr, auxBreakPtr); envPtr->currStackDepth = savedStackDepth; @@ -4075,11 +4065,9 @@ TclEmitInvoke( if (auxContinuePtr != NULL) { TclAdjustStackDepth(-1, envPtr); - exceptAux->stackDepth = auxContinuePtr->stackDepth; - exceptAux->expandTarget = auxContinuePtr->expandTarget; ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclCleanupStackForBreakContinue(envPtr, exceptAux); + TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); TclAddLoopContinueFixup(envPtr, auxContinuePtr); envPtr->currStackDepth = savedStackDepth; -- cgit v0.12 From 1356c7f642888ace1fe24f64ea003567fc6a8fdd 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 1c8937d85be2f327d881c29e203c46df34b9da08 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 Oct 2013 18:55:02 +0000 Subject: [3556215]: Made [scan] match [format] better in what it accepts as a format string, by allowing uppercase %X, %E and %G. --- doc/scan.n | 4 ++-- generic/tclScan.c | 6 ++++++ tests/scan.test | 17 +++++++++++++---- 3 files changed, 21 insertions(+), 6 deletions(-) diff --git a/doc/scan.n b/doc/scan.n index ca096da..4ee9a59 100644 --- a/doc/scan.n +++ b/doc/scan.n @@ -96,7 +96,7 @@ The input substring must be an octal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. .TP 10 -\fBx\fR +\fBx\fR or \fBX\fR The input substring must be a hexadecimal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. @@ -126,7 +126,7 @@ substring may be a white-space character. The input substring consists of all the characters up to the next white-space character; the characters are copied to the variable. .TP 10 -\fBe\fR or \fBf\fR or \fBg\fR +\fBe\fR or \fBf\fR or \fBg\fR or \fBE\fR or \fBG\fR The input substring must be a floating-point number consisting of an optional sign, a string of decimal digits possibly containing a decimal point, and an optional exponent consisting diff --git a/generic/tclScan.c b/generic/tclScan.c index d83c8c9..229f3fa 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -398,11 +398,14 @@ ValidateFormat( */ case 'd': case 'e': + case 'E': case 'f': case 'g': + case 'G': case 'i': case 'o': case 'x': + case 'X': break; case 'u': if (flags & SCAN_BIG) { @@ -727,6 +730,7 @@ Tcl_ScanObjCmd( parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES; break; case 'x': + case 'X': op = 'i'; parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY; break; @@ -738,7 +742,9 @@ Tcl_ScanObjCmd( case 'f': case 'e': + case 'E': case 'g': + case 'G': op = 'f'; break; diff --git a/tests/scan.test b/tests/scan.test index d7b72d5..109746f 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -280,6 +280,12 @@ test scan-4.48 {Tcl_ScanObjCmd, float scanning} { test scan-4.49 {Tcl_ScanObjCmd, float scanning} { list [scan {.1 0.2 3.} {%e %f %g} x y z] $x $y $z } {3 0.1 0.2 3.0} +test scan-4.49-uc-1 {Tcl_ScanObjCmd, float scanning} { + list [scan {0.5*0.75} {%E%c%G} x y z] $x $y $z +} {3 0.5 42 0.75} +test scan-4.49-uc-2 {Tcl_ScanObjCmd, float scanning} { + list [scan {5e-1*75E-2} {%E%c%G} x y z] $x $y $z +} {3 0.5 42 0.75} test scan-4.50 {Tcl_ScanObjCmd, float scanning} { list [scan {1234567890a} %f x] $x } {1 1234567890.0} @@ -359,6 +365,9 @@ test scan-4.63 {scanning of large and negative hex integers} { list [scan $scanstring {%x %x %x} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] } {3 1 1 1} +test scan-4.64 {scanning of hex with %X} { + scan "123 abc f78" %X%X%X +} {291 2748 3960} # clean up from last two tests @@ -515,14 +524,14 @@ test scan-8.4 {error conditions} { list [catch {scan a %O x} msg] $msg } {1 {bad scan conversion character "O"}} test scan-8.5 {error conditions} { - list [catch {scan a %X x} msg] $msg -} {1 {bad scan conversion character "X"}} + list [catch {scan a %B x} msg] $msg +} {1 {bad scan conversion character "B"}} test scan-8.6 {error conditions} { list [catch {scan a %F x} msg] $msg } {1 {bad scan conversion character "F"}} test scan-8.7 {error conditions} { - list [catch {scan a %E x} msg] $msg -} {1 {bad scan conversion character "E"}} + list [catch {scan a %p x} msg] $msg +} {1 {bad scan conversion character "p"}} test scan-8.8 {error conditions} { list [catch {scan a "%d %d" a} msg] $msg } {1 {different numbers of variable names and field specifiers}} -- cgit v0.12 From 2c5855aae434efce2ba3a202651709aaa5bb1ce3 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 cb8dc8b181dfb98f074698fc7eade5f9dfdbefff Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Oct 2013 15:32:58 +0000 Subject: silence compiler warning --- generic/tclCompile.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index dcd74f1..3c8e4ef 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -4034,7 +4034,6 @@ TclEmitInvoke( int savedStackDepth = envPtr->currStackDepth; int savedExpandCount = envPtr->expandCount; JumpFixup nonTrapFixup; - ExceptionAux *exceptAux = envPtr->exceptAuxArrayPtr + loopRange; if (auxBreakPtr != NULL) { auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; -- cgit v0.12 From bb5a05a1e626246d6baeabd22e419a4eee18ff66 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 0eb7f82a5693d837a2065a788ea14a0d07c3c716 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Oct 2013 12:57:19 +0000 Subject: Fix [3eb2ec1449]: Allow upper case scheme names in url. http -> 2.7.13 --- library/http/http.tcl | 21 ++++++++++++--------- library/http/pkgIndex.tcl | 2 +- tests/http.test | 4 ++-- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 19 insertions(+), 16 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 98d2c5d..4c99f62 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.4 # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.7.12 +package provide http 2.7.13 namespace eval http { # Allow resourcing to not clobber existing data @@ -107,7 +107,7 @@ proc http::Log {args} {} proc http::register {proto port command} { variable urlTypes - set urlTypes($proto) [list $port $command] + set urlTypes([string tolower $proto]) [list $port $command] } # http::unregister -- @@ -121,11 +121,12 @@ proc http::register {proto port command} { proc http::unregister {proto} { variable urlTypes - if {![info exists urlTypes($proto)]} { + set lower [string tolower $proto] + if {![info exists urlTypes($lower)]} { return -code error "unsupported url type \"$proto\"" } - set old $urlTypes($proto) - unset urlTypes($proto) + set old $urlTypes($lower) + unset urlTypes($lower) return $old } @@ -505,12 +506,13 @@ proc http::geturl {url args} { if {$proto eq ""} { set proto http } - if {![info exists urlTypes($proto)]} { + set lower [string tolower $proto] + if {![info exists urlTypes($lower)]} { unset $token return -code error "Unsupported URL type \"$proto\"" } - set defport [lindex $urlTypes($proto) 0] - set defcmd [lindex $urlTypes($proto) 1] + set defport [lindex $urlTypes($lower) 0] + set defcmd [lindex $urlTypes($lower) 1] if {$port eq ""} { set port $defport @@ -641,7 +643,8 @@ proc http::Connected { token proto phost srvurl} { set host [lindex [split $state(socketinfo) :] 0] set port [lindex [split $state(socketinfo) :] 1] - set defport [lindex $urlTypes($proto) 0] + set lower [string tolower $proto] + set defport [lindex $urlTypes($lower) 0] # Send data in cr-lf format, but accept any line terminators diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 0157b3c..be8b883 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,4 +1,4 @@ # Tcl package index file, version 1.1 if {![package vsatisfies [package provide Tcl] 8.4]} {return} -package ifneeded http 2.7.12 [list tclPkgSetup $dir http 2.7.12 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.7.13 [list tclPkgSetup $dir http 2.7.13 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/tests/http.test b/tests/http.test index c974990..81e16a1 100644 --- a/tests/http.test +++ b/tests/http.test @@ -120,7 +120,7 @@ test http-3.2 {http::geturl} { set err } {Unsupported URL: http:junk} set url //[info hostname]:$port -set badurl //[info hostname]:6666 +set badurl //[info hostname]:[expr $port+1] test http-3.3 {http::geturl} { set token [http::geturl $url] http::data $token @@ -130,7 +130,7 @@ test http-3.3 {http::geturl} { " set tail /a/b/c set url //[info hostname]:$port/a/b/c -set fullurl http://user:pass@[info hostname]:$port/a/b/c +set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c set binurl //[info hostname]:$port/binary set posturl //[info hostname]:$port/post set badposturl //[info hostname]:$port/droppost diff --git a/unix/Makefile.in b/unix/Makefile.in index f6c4424..7c567d3 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -766,8 +766,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; - @echo "Installing package http 2.7.12 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/http-2.7.12.tm; + @echo "Installing package http 2.7.13 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/http-2.7.13.tm; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index 2d97807..7d9e844 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -642,8 +642,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.7.12 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/http-2.7.12.tm; + @echo "Installing package http 2.7.13 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/http-2.7.13.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From fdfd431637d67d40a0af98bfe92a2771a2852e94 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 ab8249dfc3c847de69ae379bb7849bdb7346db40 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 2fb0507a00743b52c4e5d679639bfb6cbc8b69b6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 27 Oct 2013 08:28:43 +0000 Subject: [53a917d6c9]: Correction to macro for determining how to deprecate things. Thanks to Raphael Kubo da Costa for the patch. --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index 1b120fb..ab54078 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -168,7 +168,7 @@ extern "C" { */ #if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1))) -# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC__MINOR__ >= 5)) +# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 5)) # define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__ (msg))) # else # define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__)) -- cgit v0.12 From c6fdd0f07eb9197e59da6170e89c7beafd0a43e0 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 28 Oct 2013 09:23:30 +0000 Subject: [01b77111e5]: Small fixes relating to this bug. In particular, the package name mapping was not being distributed, and there were some small problems with what the mappings were and how they were applied. Also prevented external URLs from ending with a '.'; that's vanishingly rare... --- pkgs/package.list.txt | 11 +++++++- tools/tcltk-man2html-utils.tcl | 2 +- tools/tcltk-man2html.tcl | 9 +++++-- unix/Makefile.in | 57 +++++++++++++++++++++--------------------- 4 files changed, 47 insertions(+), 32 deletions(-) diff --git a/pkgs/package.list.txt b/pkgs/package.list.txt index a13b0fb..0d5dcf8 100644 --- a/pkgs/package.list.txt +++ b/pkgs/package.list.txt @@ -9,7 +9,10 @@ itcl {[incr Tcl]} Itcl {[incr Tcl]} # SQLite -sqlite SQLite +Sqlite SQLite3 +sqlite SQLite3 +Sqlite3 SQLite3 +sqlite3 SQLite3 # Thread Thread Thread @@ -20,7 +23,13 @@ tdbc TDBC Tdbc TDBC TDBC TDBC # Drivers for TDBC +Tdbcmysql tdbc::mysql tdbcmysql tdbc::mysql +Tdbcodbc tdbc::odbc tdbcodbc tdbc::odbc +Tdbcpostgres tdbc::postgres tdbcpostgres tdbc::postgres +Tdbcsqlite3 tdbc::sqlite3 tdbcsqlite3 tdbc::sqlite3 +Tdbcsqlite tdbc::sqlite3 +tdbcsqlite tdbc::sqlite3 diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index d02bcb6..bdd0079 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -900,7 +900,7 @@ proc insert-cross-references {text} { append result [string range $text 0 [expr {$off-1}]] regexp -indices -start $off {http://[\w/.]+} $text range set url [string range $text {*}$range] - append result "" $url "" + append result "$url" set text [string range $text[set text ""] \ [expr {[lindex $range 1]+1}] end] continue diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index f392bce..89e8e5c 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -470,6 +470,7 @@ proc plus-pkgs {type args} { continue } } + set dir [string trimright $dir "0123456789-."] switch $type { n { set title "$name Package Commands" @@ -647,10 +648,12 @@ try { append appdir "$tkdir" } + apply {{} { + global packageBuildList tcltkdir tcldir build_tcl # When building docs for Tcl, try to build docs for bundled packages too set packageBuildList {} - if {$build_tcl} { + if {$build_tcl} { set pkgsDir [file join $tcltkdir $tcldir pkgs] set subdirs [glob -nocomplain -types d -tails -directory $pkgsDir *] @@ -693,7 +696,8 @@ try { foreach line [split [read $f] \n] { if {[string trim $line] eq ""} continue if {[string match #* $line]} continue - lappend packageDirNameMap {*}$line + lassign $line dir name + lappend packageDirNameMap $dir $name } } finally { close $f @@ -714,6 +718,7 @@ try { lset packageBuildList $idx+1 [dict get $packageDirNameMap $n] } } + }} # # Invoke the scraper/converter engine. diff --git a/unix/Makefile.in b/unix/Makefile.in index bc396e2..093fb40 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1950,6 +1950,7 @@ $(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure cd $(MAC_OSX_DIR); autoheader; touch $@ +EOLFIX=$(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH} rm -rf $(DISTDIR) mkdir -p $(DISTDIR)/unix @@ -1965,7 +1966,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M $(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in chmod 775 $(DISTDIR)/unix/ldAix - mkdir $(DISTDIR)/generic + @mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic @@ -1973,7 +1974,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README* \ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \ $(DISTDIR) - mkdir $(DISTDIR)/library + @mkdir $(DISTDIR)/library cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library for i in http1.0 http opt msgcat reg dde tcltest platform; \ @@ -1981,31 +1982,32 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M mkdir $(DISTDIR)/library/$$i ;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done; - mkdir $(DISTDIR)/library/encoding + @mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding - mkdir $(DISTDIR)/library/msgs + @mkdir $(DISTDIR)/library/msgs cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs - ( cd $(TOP_DIR); \ + @echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata + @( cd $(TOP_DIR); \ find library/tzdata -name CVS -prune -o -type f -print ) \ | ( cd $(TOP_DIR) ; xargs tar cf - ) \ | ( cd $(DISTDIR) ; tar xfp - ) - mkdir $(DISTDIR)/doc + @mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc - mkdir $(DISTDIR)/compat + @mkdir $(DISTDIR)/compat cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \ $(COMPAT_DIR)/README $(DISTDIR)/compat - mkdir $(DISTDIR)/compat/zlib + @mkdir $(DISTDIR)/compat/zlib ( cd $(COMPAT_DIR)/zlib; \ find . -name CVS -prune -o -type f -print ) \ | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \ | ( cd $(DISTDIR)/compat/zlib ; tar xfp - ) - mkdir $(DISTDIR)/tests + @mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ $(DISTDIR)/tests - mkdir $(DISTDIR)/win + @mkdir $(DISTDIR)/win cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win cp $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \ $(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \ @@ -2014,49 +2016,48 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M cp -p $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/*.bat + @$(EOLFIX) -crlf $(DISTDIR)/win/*.bat cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/makefile.* + @$(EOLFIX) -crlf $(DISTDIR)/win/makefile.* cp -p $(TOP_DIR)/win/rules.vc $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/rules.vc + @$(EOLFIX) -crlf $(DISTDIR)/win/rules.vc cp -p $(TOP_DIR)/win/coffbase.txt $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/coffbase.txt + @$(EOLFIX) -crlf $(DISTDIR)/win/coffbase.txt cp -p $(TOP_DIR)/win/tcl.hpj.in $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.hpj.in + @$(EOLFIX) -crlf $(DISTDIR)/win/tcl.hpj.in cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.ds* + @$(EOLFIX) -crlf $(DISTDIR)/win/tcl.ds* cp -p $(TOP_DIR)/win/README $(DISTDIR)/win cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win - mkdir $(DISTDIR)/macosx + @mkdir $(DISTDIR)/macosx cp -p $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ $(MAC_OSX_DIR)/*.ac $(MAC_OSX_DIR)/*.xcconfig \ $(MAC_OSX_DIR)/configure $(DISTDIR)/macosx cp -p $(TOP_DIR)/license.terms $(DISTDIR)/macosx - mkdir $(DISTDIR)/macosx/Tcl.xcode + @mkdir $(DISTDIR)/macosx/Tcl.xcode cp -p $(MAC_OSX_DIR)/Tcl.xcode/project.pbxproj \ $(MAC_OSX_DIR)/Tcl.xcode/default.pbxuser \ $(DISTDIR)/macosx/Tcl.xcode - mkdir $(DISTDIR)/macosx/Tcl.xcodeproj + @mkdir $(DISTDIR)/macosx/Tcl.xcodeproj cp -p $(MAC_OSX_DIR)/Tcl.xcodeproj/project.pbxproj \ $(MAC_OSX_DIR)/Tcl.xcodeproj/default.pbxuser \ $(DISTDIR)/macosx/Tcl.xcodeproj - mkdir $(DISTDIR)/unix/dltest + @mkdir $(DISTDIR)/unix/dltest cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ - $(UNIX_DIR)/dltest/README \ - $(DISTDIR)/unix/dltest - mkdir $(DISTDIR)/tools + $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest + @mkdir $(DISTDIR)/tools cp -p $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \ $(TOOL_DIR)/configure $(TOOL_DIR)/configure.in \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \ $(TOOL_DIR)/*.bmp $(TOOL_DIR)/tcl.hpj.in \ $(DISTDIR)/tools - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in - mkdir $(DISTDIR)/libtommath - cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h \ - $(DISTDIR)/libtommath - mkdir $(DISTDIR)/pkgs + @$(EOLFIX) -crlf $(DISTDIR)/tools/tcl.hpj.in + @mkdir $(DISTDIR)/libtommath + cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h $(DISTDIR)/libtommath + @mkdir $(DISTDIR)/pkgs cp $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs + cp $(TOP_DIR)/pkgs/package.list.txt $(DISTDIR)/pkgs for i in `ls $(DISTROOT)/pkgs/*.tar.gz 2> /dev/null`; do \ tar -C $(DISTDIR)/pkgs -xzf "$$i"; \ done -- cgit v0.12 From 9948d29038eeaaed7e7f3a5d39b22b5462f2c825 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Oct 2013 10:55:37 +0000 Subject: Bump tcltest version to 2.3.6 (should have been done just before the 8.5.15 release, just as in Tcl 8.6.1). Don't fix eol-style for Makefile.in in "make dist", if the file system is case-insensitive/case-preserving. --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 2 +- unix/Makefile.in | 89 ++++++++++++++++++++++++++++---------------- win/Makefile.in | 4 +- 4 files changed, 60 insertions(+), 37 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 4b0a9bc..60a9485 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.5 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d6e6487..c30d2e4 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.5 + variable Version 2.3.6 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] diff --git a/unix/Makefile.in b/unix/Makefile.in index 7c567d3..210d90b 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -308,7 +308,7 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \ bn_mp_radix_size.o bn_mp_radix_smap.o \ bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_set_int.o \ - bn_mp_shrink.o \ + bn_mp_shrink.o \ bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \ @@ -540,6 +540,10 @@ DTRACE_SRC = $(GENERIC_DIR)/tclDTrace.d SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \ $(STUB_SRCS) @PLAT_SRCS@ +#-------------------------------------------------------------------------- +# Start of rules +#-------------------------------------------------------------------------- + all: binaries libraries doc binaries: ${LIB_FILE} $(STUB_LIB_FILE) ${TCL_EXE} @@ -719,11 +723,11 @@ install-binaries: binaries done; @echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/" @@INSTALL_LIB@ - @chmod 555 "$(DLL_INSTALL_DIR)"/$(LIB_FILE) + @chmod 555 "$(DLL_INSTALL_DIR)/$(LIB_FILE)" @echo "Installing ${TCL_EXE} as $(BIN_INSTALL_DIR)/tclsh$(VERSION)@EXEEXT@" - @$(INSTALL_PROGRAM) ${TCL_EXE} "$(BIN_INSTALL_DIR)"/tclsh$(VERSION)@EXEEXT@ + @$(INSTALL_PROGRAM) ${TCL_EXE} "$(BIN_INSTALL_DIR)/tclsh$(VERSION)@EXEEXT@" @echo "Installing tclConfig.sh to $(CONFIG_INSTALL_DIR)/" - @$(INSTALL_DATA) tclConfig.sh "$(CONFIG_INSTALL_DIR)"/tclConfig.sh + @$(INSTALL_DATA) tclConfig.sh "$(CONFIG_INSTALL_DIR)/tclConfig.sh" @if test "$(STUB_LIB_FILE)" != "" ; then \ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ @INSTALL_STUB_LIB@ ; \ @@ -775,8 +779,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.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.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 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; @@ -854,10 +858,12 @@ install-doc: doc @for i in $(TOP_DIR)/doc/*.1; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \ done + @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.3; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \ done + @echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.n; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \ @@ -902,6 +908,10 @@ distclean: clean depend: makedepend -- $(DEPEND_SWITCHES) -- $(SRCS) +#-------------------------------------------------------------------------- +# Rules for how to compile C files +#-------------------------------------------------------------------------- + # Test binaries. The rules for tclTestInit.o and xtTestInit.o are complicated # because they are compiled from tclAppInit.c. Can't use the "-o" option # because this doesn't work on some strange compilers (e.g. UnixWare). @@ -1134,7 +1144,7 @@ tclPkg.o: $(GENERIC_DIR)/tclPkg.c # prefix/exec_prefix but all the different paths individually. tclPkgConfig.o: $(GENERIC_DIR)/tclPkgConfig.c - $(CC) -c $(CC_SWITCHES) \ + $(CC) -c $(CC_SWITCHES) \ -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR)\"" \ -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR)\"" \ -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR)\"" \ @@ -1475,11 +1485,13 @@ $(DTRACE_HDR): $(DTRACE_SRC) $(DTRACE_OBJ): $(DTRACE_SRC) $(TCL_OBJS) $(DTRACE) -G $(DTRACE_SWITCHES) -o $@ -s $(DTRACE_SRC) $(TCL_OBJS) +#-------------------------------------------------------------------------- # The following targets are not completely general. They are provide purely # for documentation purposes so people who are interested in the Xt based # notifier can modify them to suit their own installation. +#-------------------------------------------------------------------------- -xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ +xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ @DL_OBJS@ ${BUILD_DLTEST} ${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ @DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \ @@ -1493,10 +1505,12 @@ tclXtTest.o: $(UNIX_DIR)/tclXtTest.c $(CC) -c $(APP_CC_SWITCHES) -I/usr/openwin/include \ $(UNIX_DIR)/tclXtTest.c +#-------------------------------------------------------------------------- # Compat binaries, these must be compiled for use in a shared library even # though they may be placed in a static executable or library. Since they are # included in both the tcl library and the stub library, they need to be # relocatable. +#-------------------------------------------------------------------------- fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c @@ -1525,8 +1539,10 @@ strtoul.o: $(COMPAT_DIR)/strtoul.c waitpid.o: $(COMPAT_DIR)/waitpid.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c +#-------------------------------------------------------------------------- # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive +#-------------------------------------------------------------------------- tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLib.c @@ -1600,6 +1616,10 @@ checkexports: $(TCL_LIB_FILE) | awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \ | sort -n | grep -E -v '^[Tt]cl' || true +#-------------------------------------------------------------------------- +# Distribution building rules +#-------------------------------------------------------------------------- + # # Target to create a Tcl RPM for Linux. Requires that you be on a Linux # system. @@ -1633,6 +1653,7 @@ $(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure cd $(MAC_OSX_DIR); autoheader; touch $@ +EOLFIX=$(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure genstubs rm -rf $(DISTDIR) mkdir -p $(DISTDIR)/unix @@ -1647,7 +1668,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure $(DISTDIR)/unix chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in chmod 775 $(DISTDIR)/unix/ldAix - mkdir $(DISTDIR)/generic + @mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic @@ -1655,7 +1676,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README* \ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \ $(DISTDIR) - mkdir $(DISTDIR)/library + @mkdir $(DISTDIR)/library cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library for i in http1.0 http opt msgcat reg dde tcltest platform; \ @@ -1663,26 +1684,27 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure mkdir $(DISTDIR)/library/$$i ;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done; - mkdir $(DISTDIR)/library/encoding + @mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding - mkdir $(DISTDIR)/library/msgs + @mkdir $(DISTDIR)/library/msgs cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs - ( cd $(TOP_DIR); \ + @echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata + @( cd $(TOP_DIR); \ find library/tzdata -name CVS -prune -o -type f -print ) \ | ( cd $(TOP_DIR) ; xargs tar cf - ) \ | ( cd $(DISTDIR) ; tar xfp - ) - mkdir $(DISTDIR)/doc + @mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc - mkdir $(DISTDIR)/compat + @mkdir $(DISTDIR)/compat cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \ $(COMPAT_DIR)/README $(DISTDIR)/compat - mkdir $(DISTDIR)/tests + @mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ $(DISTDIR)/tests - mkdir $(DISTDIR)/win + @mkdir $(DISTDIR)/win cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win cp $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \ $(TOP_DIR)/win/tclConfig.sh.in \ @@ -1691,45 +1713,45 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure cp -p $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/*.bat + @$(EOLFIX) -crlf $(DISTDIR)/win/*.bat cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/makefile.* + @$(EOLFIX) -crlf $(DISTDIR)/win/makefile.bc $(DISTDIR)/win/makefile.vc cp -p $(TOP_DIR)/win/rules.vc $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/rules.vc + @$(EOLFIX) -crlf $(DISTDIR)/win/rules.vc cp -p $(TOP_DIR)/win/coffbase.txt $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/coffbase.txt + @$(EOLFIX) -crlf $(DISTDIR)/win/coffbase.txt cp -p $(TOP_DIR)/win/tcl.hpj.in $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.hpj.in + @$(EOLFIX) -crlf $(DISTDIR)/win/tcl.hpj.in cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.ds* + @$(EOLFIX) -crlf $(DISTDIR)/win/tcl.ds* cp -p $(TOP_DIR)/win/README $(DISTDIR)/win cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win - mkdir $(DISTDIR)/macosx + @mkdir $(DISTDIR)/macosx cp -p $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ $(MAC_OSX_DIR)/*.ac $(MAC_OSX_DIR)/*.xcconfig \ $(MAC_OSX_DIR)/configure $(DISTDIR)/macosx cp -p $(TOP_DIR)/license.terms $(DISTDIR)/macosx - mkdir $(DISTDIR)/macosx/Tcl.pbproj + @mkdir $(DISTDIR)/macosx/Tcl.pbproj cp -p $(MAC_OSX_DIR)/Tcl.pbproj/*.pbx* $(DISTDIR)/macosx/Tcl.pbproj - mkdir $(DISTDIR)/macosx/Tcl.xcode + @mkdir $(DISTDIR)/macosx/Tcl.xcode cp -p $(MAC_OSX_DIR)/Tcl.xcode/*.pbx* $(DISTDIR)/macosx/Tcl.xcode - mkdir $(DISTDIR)/macosx/Tcl.xcodeproj + @mkdir $(DISTDIR)/macosx/Tcl.xcodeproj cp -p $(TOP_DIR)/macosx/Tcl.xcodeproj/*.pbx* $(DISTDIR)/macosx/Tcl.xcodeproj - mkdir $(DISTDIR)/unix/dltest + @mkdir $(DISTDIR)/unix/dltest cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README \ $(DISTDIR)/unix/dltest - mkdir $(DISTDIR)/tools + @mkdir $(DISTDIR)/tools cp -p $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \ $(TOOL_DIR)/configure $(TOOL_DIR)/configure.in \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \ $(TOOL_DIR)/tcl.wse.in $(TOOL_DIR)/*.bmp \ $(TOOL_DIR)/tcl.hpj.in \ $(DISTDIR)/tools - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in \ + @$(EOLFIX)-crlf $(DISTDIR)/tools/tcl.hpj.in \ $(DISTDIR)/tools/tcl.wse.in - mkdir $(DISTDIR)/libtommath + @mkdir $(DISTDIR)/libtommath cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h \ $(DISTDIR)/libtommath @@ -1738,12 +1760,12 @@ alldist: dist cd $(DISTROOT); tar cf $(DISTNAME)-src.tar $(DISTNAME); \ gzip -9 $(DISTNAME)-src.tar; zip -qr8 $(ZIPNAME) $(DISTNAME) -# +#-------------------------------------------------------------------------- # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool # workspace. It depends on the Tcl & Tk being in directories called tcl8.* & # tk8.* up two directories from the TOOL_DIR. -# +#-------------------------------------------------------------------------- html: ${TCL_EXE} $(BUILD_HTML) @@ -1839,4 +1861,5 @@ package-generate: pkgtrans -s . $(PACKAGE).`arch` $(PACKAGE) rm -rf $(PACKAGE) +#-------------------------------------------------------------------------- # DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/win/Makefile.in b/win/Makefile.in index 7d9e844..e0b2f26 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.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.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 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 5873d26c7268ee5af9f31c126c64b4350736c458 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Oct 2013 08:15:36 +0000 Subject: Workaround for [414d10346b]: tcl 8.5.15/8.6.1(threaded build) hangs in exec on HP-UX --- unix/tclUnixNotfy.c | 6 +++--- unix/tclUnixTest.c | 5 ++--- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index f41ef68..8e59044 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -202,7 +202,7 @@ static Tcl_ThreadId notifierThread; #ifdef TCL_THREADS static void NotifierThreadProc(ClientData clientData); -#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) && !defined(__hpux) static int atForkInit = 0; static void AtForkPrepare(void); static void AtForkParent(void); @@ -282,7 +282,7 @@ Tcl_InitNotifier(void) */ Tcl_MutexLock(¬ifierMutex); -#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) && !defined(__hpux) /* * Install pthread_atfork handlers to reinitialize the notifier in the * child of a fork. @@ -1273,7 +1273,7 @@ NotifierThreadProc( TclpThreadExit (0); } -#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) && !defined(__hpux) /* *---------------------------------------------------------------------- * diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index bb16f3b..0747c2d 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -574,12 +574,11 @@ TestforkObjCmd( "Cannot fork", NULL); return TCL_ERROR; } -#if !defined(HAVE_PTHREAD_ATFORK) - /* Only needed when pthread_atfork is not present. */ + /* Only needed when pthread_atfork is not present, + * should not hurt otherwise. */ if (pid==0) { Tcl_InitNotifier(); } -#endif Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); return TCL_OK; } -- cgit v0.12 From 3b3f0179aee2dce77bfef12308c53429523675bc 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 b5f69350e3ff6666d6077535041901c8d04b3617 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Oct 2013 11:44:37 +0000 Subject: Windows dll's should be executable. --- compat/zlib/win32/zlib1.dll | Bin compat/zlib/win64/zlib1.dll | Bin 2 files changed, 0 insertions(+), 0 deletions(-) mode change 100644 => 100755 compat/zlib/win32/zlib1.dll mode change 100644 => 100755 compat/zlib/win64/zlib1.dll diff --git a/compat/zlib/win32/zlib1.dll b/compat/zlib/win32/zlib1.dll old mode 100644 new mode 100755 diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll old mode 100644 new mode 100755 -- cgit v0.12 From 49f8bb2d42c970325160658862b0a7f0e2cd066a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Nov 2013 10:02:58 +0000 Subject: Put extern "C" guards around all stub table struct definitions, so it is usable for C++ compilers as well without the danger of modifying the calling convention. For tclDecls.h it was no problem, because tcl.h already contains those guards. But for the other *Decls.h files (e.g. tclTomMathDecls.h) it was not correct. --- generic/tclDecls.h | 8 +++++--- generic/tclIntDecls.h | 8 +++++--- generic/tclIntPlatDecls.h | 8 +++++--- generic/tclPlatDecls.h | 8 +++++--- generic/tclTomMathDecls.h | 8 +++++--- tools/genStubs.tcl | 5 +++-- 6 files changed, 28 insertions(+), 17 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4ca9f68..b11c0d8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -31,6 +31,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -4131,10 +4135,8 @@ typedef struct TclStubs { void (*tclUnusedStubEntry) (void); /* 630 */ } TclStubs; -#ifdef __cplusplus -extern "C" { -#endif extern TclStubs *tclStubsPtr; + #ifdef __cplusplus } #endif diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 1dc797a..e4e85ad 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -50,6 +50,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -1309,10 +1313,8 @@ typedef struct TclIntStubs { char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ } TclIntStubs; -#ifdef __cplusplus -extern "C" { -#endif extern TclIntStubs *tclIntStubsPtr; + #ifdef __cplusplus } #endif diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 1e68c9c..80dd2ad 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -37,6 +37,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -533,10 +537,8 @@ typedef struct TclIntPlatStubs { #endif /* MACOSX */ } TclIntPlatStubs; -#ifdef __cplusplus -extern "C" { -#endif extern TclIntPlatStubs *tclIntPlatStubsPtr; + #ifdef __cplusplus } #endif diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 8652e8d..ef23c84 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -36,6 +36,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -87,10 +91,8 @@ typedef struct TclPlatStubs { #endif /* MACOSX */ } TclPlatStubs; -#ifdef __cplusplus -extern "C" { -#endif extern TclPlatStubs *tclPlatStubsPtr; + #ifdef __cplusplus } #endif diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 04a23f3..056ad85 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -134,6 +134,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -538,10 +542,8 @@ typedef struct TclTomMathStubs { int (*tclBN_mp_cnt_lsb) (mp_int *a); /* 63 */ } TclTomMathStubs; -#ifdef __cplusplus -extern "C" { -#endif extern TclTomMathStubs *tclTomMathStubsPtr; + #ifdef __cplusplus } #endif diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index c7dbe93..37205b2 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -991,6 +991,8 @@ proc genStubs::emitHeader {name} { append text "#define ${CAPName}_STUBS_REVISION $revision\n" } + append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n" + emitDeclarations $name text if {[info exists hooks($name)]} { @@ -1014,8 +1016,7 @@ proc genStubs::emitHeader {name} { append text "} ${capName}Stubs;\n\n" - append text "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" - append text "extern ${capName}Stubs *${name}StubsPtr;\n" + append text "extern ${capName}Stubs *${name}StubsPtr;\n\n" append text "#ifdef __cplusplus\n}\n#endif\n" emitMacros $name text -- cgit v0.12 From cda2a285e3db35f852210c948e5ccff1e69806f6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 5 Nov 2013 12:36:17 +0000 Subject: Fix [426679ef7d]: Having man.macros after .TH breaks rendering on OpenBSD and possibly others. --- doc/Access.3 | 2 +- doc/AddErrInfo.3 | 2 +- doc/Alloc.3 | 2 +- doc/AllowExc.3 | 2 +- doc/AppInit.3 | 2 +- doc/AssocData.3 | 2 +- doc/Async.3 | 2 +- doc/BackgdErr.3 | 2 +- doc/Backslash.3 | 2 +- doc/BoolObj.3 | 2 +- doc/ByteArrObj.3 | 2 +- doc/CallDel.3 | 2 +- doc/ChnlStack.3 | 2 +- doc/CmdCmplt.3 | 2 +- doc/Concat.3 | 2 +- doc/CrtChannel.3 | 2 +- doc/CrtChnlHdlr.3 | 2 +- doc/CrtCloseHdlr.3 | 2 +- doc/CrtCommand.3 | 2 +- doc/CrtFileHdlr.3 | 2 +- doc/CrtInterp.3 | 2 +- doc/CrtMathFnc.3 | 2 +- doc/CrtObjCmd.3 | 2 +- doc/CrtSlave.3 | 2 +- doc/CrtTimerHdlr.3 | 2 +- doc/CrtTrace.3 | 2 +- doc/DString.3 | 2 +- doc/DetachPids.3 | 2 +- doc/DictObj.3 | 2 +- doc/DoOneEvent.3 | 2 +- doc/DoWhenIdle.3 | 2 +- doc/DoubleObj.3 | 2 +- doc/DumpActiveMemory.3 | 2 +- doc/Encoding.3 | 2 +- doc/Ensemble.3 | 2 +- doc/Environment.3 | 2 +- doc/Eval.3 | 2 +- doc/Exit.3 | 2 +- doc/ExprLong.3 | 2 +- doc/ExprLongObj.3 | 2 +- doc/FileSystem.3 | 2 +- doc/FindExec.3 | 2 +- doc/GetCwd.3 | 2 +- doc/GetHostName.3 | 2 +- doc/GetIndex.3 | 2 +- doc/GetInt.3 | 2 +- doc/GetOpnFl.3 | 2 +- doc/GetStdChan.3 | 2 +- doc/GetTime.3 | 2 +- doc/GetVersion.3 | 2 +- doc/Hash.3 | 2 +- doc/Init.3 | 2 +- doc/InitStubs.3 | 2 +- doc/IntObj.3 | 2 +- doc/Interp.3 | 2 +- doc/Limit.3 | 2 +- doc/LinkVar.3 | 2 +- doc/ListObj.3 | 2 +- doc/Namespace.3 | 2 +- doc/Notifier.3 | 2 +- doc/Object.3 | 2 +- doc/ObjectType.3 | 2 +- doc/OpenFileChnl.3 | 2 +- doc/OpenTcp.3 | 2 +- doc/Panic.3 | 2 +- doc/ParseCmd.3 | 2 +- doc/PkgRequire.3 | 2 +- doc/Preserve.3 | 2 +- doc/PrintDbl.3 | 2 +- doc/RecEvalObj.3 | 2 +- doc/RecordEval.3 | 2 +- doc/RegConfig.3 | 2 +- doc/RegExp.3 | 2 +- doc/SaveResult.3 | 2 +- doc/SetChanErr.3 | 2 +- doc/SetErrno.3 | 2 +- doc/SetRecLmt.3 | 2 +- doc/SetResult.3 | 2 +- doc/SetVar.3 | 2 +- doc/Signal.3 | 2 +- doc/Sleep.3 | 2 +- doc/SourceRCFile.3 | 2 +- doc/SplitList.3 | 2 +- doc/SplitPath.3 | 2 +- doc/StaticPkg.3 | 2 +- doc/StdChannels.3 | 2 +- doc/StrMatch.3 | 2 +- doc/StringObj.3 | 2 +- doc/SubstObj.3 | 2 +- doc/TCL_MEM_DEBUG.3 | 2 +- doc/Tcl.n | 2 +- doc/Tcl_Main.3 | 2 +- doc/Thread.3 | 2 +- doc/ToUpper.3 | 2 +- doc/TraceCmd.3 | 2 +- doc/TraceVar.3 | 2 +- doc/Translate.3 | 2 +- doc/UniCharIsAlpha.3 | 2 +- doc/UpVar.3 | 2 +- doc/Utf.3 | 2 +- doc/WrongNumArgs.3 | 2 +- doc/after.n | 2 +- doc/append.n | 2 +- doc/apply.n | 2 +- doc/array.n | 2 +- doc/bgerror.n | 2 +- doc/binary.n | 2 +- doc/break.n | 2 +- doc/case.n | 2 +- doc/catch.n | 2 +- doc/cd.n | 2 +- doc/chan.n | 2 +- doc/clock.n | 2 +- doc/close.n | 2 +- doc/concat.n | 2 +- doc/continue.n | 2 +- doc/dde.n | 2 +- doc/dict.n | 2 +- doc/encoding.n | 2 +- doc/eof.n | 2 +- doc/error.n | 2 +- doc/eval.n | 2 +- doc/exec.n | 2 +- doc/exit.n | 2 +- doc/expr.n | 2 +- doc/fblocked.n | 2 +- doc/fconfigure.n | 2 +- doc/fcopy.n | 2 +- doc/file.n | 2 +- doc/fileevent.n | 2 +- doc/filename.n | 2 +- doc/flush.n | 2 +- doc/for.n | 2 +- doc/foreach.n | 2 +- doc/format.n | 2 +- doc/gets.n | 2 +- doc/glob.n | 2 +- doc/global.n | 2 +- doc/history.n | 2 +- doc/http.n | 2 +- doc/if.n | 2 +- doc/incr.n | 2 +- doc/info.n | 2 +- doc/interp.n | 2 +- doc/join.n | 2 +- doc/lappend.n | 2 +- doc/lassign.n | 2 +- doc/library.n | 2 +- doc/lindex.n | 2 +- doc/linsert.n | 2 +- doc/list.n | 2 +- doc/llength.n | 2 +- doc/load.n | 2 +- doc/lrange.n | 2 +- doc/lrepeat.n | 2 +- doc/lreplace.n | 2 +- doc/lreverse.n | 2 +- doc/lsearch.n | 2 +- doc/lset.n | 2 +- doc/lsort.n | 2 +- doc/mathfunc.n | 2 +- doc/mathop.n | 2 +- doc/memory.n | 2 +- doc/msgcat.n | 2 +- doc/namespace.n | 2 +- doc/open.n | 2 +- doc/package.n | 2 +- doc/packagens.n | 2 +- doc/pid.n | 2 +- doc/pkgMkIndex.n | 2 +- doc/platform.n | 2 +- doc/platform_shell.n | 2 +- doc/proc.n | 2 +- doc/puts.n | 2 +- doc/pwd.n | 2 +- doc/re_syntax.n | 2 +- doc/read.n | 2 +- doc/refchan.n | 2 +- doc/regexp.n | 2 +- doc/registry.n | 2 +- doc/regsub.n | 2 +- doc/rename.n | 2 +- doc/return.n | 2 +- doc/safe.n | 2 +- doc/scan.n | 2 +- doc/seek.n | 2 +- doc/set.n | 2 +- doc/socket.n | 2 +- doc/source.n | 2 +- doc/split.n | 2 +- doc/string.n | 2 +- doc/subst.n | 2 +- doc/switch.n | 2 +- doc/tclsh.1 | 2 +- doc/tcltest.n | 2 +- doc/tclvars.n | 2 +- doc/tell.n | 2 +- doc/time.n | 2 +- doc/tm.n | 2 +- doc/trace.n | 2 +- doc/unknown.n | 2 +- doc/unload.n | 2 +- doc/unset.n | 2 +- doc/update.n | 2 +- doc/uplevel.n | 2 +- doc/upvar.n | 2 +- doc/variable.n | 2 +- doc/vwait.n | 2 +- doc/while.n | 2 +- 209 files changed, 209 insertions(+), 209 deletions(-) diff --git a/doc/Access.3 b/doc/Access.3 index 98d6635..b77e5fa 100644 --- a/doc/Access.3 +++ b/doc/Access.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Access 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Access, Tcl_Stat \- check file permissions and other attributes diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index 136a16f..577b6c7 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options diff --git a/doc/Alloc.3 b/doc/Alloc.3 index ca4f949..585704a 100644 --- a/doc/Alloc.3 +++ b/doc/Alloc.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory diff --git a/doc/AllowExc.3 b/doc/AllowExc.3 index ae595f1..2343e66 100644 --- a/doc/AllowExc.3 +++ b/doc/AllowExc.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_AllowExceptions 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_AllowExceptions \- allow all exceptions in next script evaluation diff --git a/doc/AppInit.3 b/doc/AppInit.3 index 0473090..6a329e2 100644 --- a/doc/AppInit.3 +++ b/doc/AppInit.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_AppInit 3 7.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_AppInit \- perform application-specific initialization diff --git a/doc/AssocData.3 b/doc/AssocData.3 index e4c7bab..c402057 100644 --- a/doc/AssocData.3 +++ b/doc/AssocData.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetAssocData 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage associations of string keys and user specified data with Tcl interpreters diff --git a/doc/Async.3 b/doc/Async.3 index c4439a4..d7a5147 100644 --- a/doc/Async.3 +++ b/doc/Async.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events diff --git a/doc/BackgdErr.3 b/doc/BackgdErr.3 index 1e46b03..4291167 100644 --- a/doc/BackgdErr.3 +++ b/doc/BackgdErr.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_BackgroundError 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_BackgroundError \- report Tcl error that occurred in background processing diff --git a/doc/Backslash.3 b/doc/Backslash.3 index 8b399fc..f121c7c 100644 --- a/doc/Backslash.3 +++ b/doc/Backslash.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Backslash \- parse a backslash sequence diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index 395d159..f10ae88 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_BooleanObj 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 738da32..c031d53 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl objects as a arrays of bytes diff --git a/doc/CallDel.3 b/doc/CallDel.3 index 8e6445b..0f53b2e 100644 --- a/doc/CallDel.3 +++ b/doc/CallDel.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CallWhenDeleted 3 7.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CallWhenDeleted, Tcl_DontCallWhenDeleted \- Arrange for callback when interpreter is deleted diff --git a/doc/ChnlStack.3 b/doc/ChnlStack.3 index 8ac5a0d..16dc745 100644 --- a/doc/ChnlStack.3 +++ b/doc/ChnlStack.3 @@ -3,8 +3,8 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -.so man.macros .TH Tcl_StackChannel 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/CmdCmplt.3 b/doc/CmdCmplt.3 index eeae039..25b372e 100644 --- a/doc/CmdCmplt.3 +++ b/doc/CmdCmplt.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CommandComplete 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CommandComplete \- Check for unmatched braces in a Tcl command diff --git a/doc/Concat.3 b/doc/Concat.3 index c38bf82..58a0fb6 100644 --- a/doc/Concat.3 +++ b/doc/Concat.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Concat \- concatenate a collection of strings diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index 212a239..21b5c37 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -4,8 +4,8 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -.so man.macros .TH Tcl_CreateChannel 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/CrtChnlHdlr.3 b/doc/CrtChnlHdlr.3 index f5fd1bd..affd7e2 100644 --- a/doc/CrtChnlHdlr.3 +++ b/doc/CrtChnlHdlr.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateChannelHandler 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/CrtCloseHdlr.3 b/doc/CrtCloseHdlr.3 index c8804b1..9406ece 100644 --- a/doc/CrtCloseHdlr.3 +++ b/doc/CrtCloseHdlr.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateCloseHandler 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/CrtCommand.3 b/doc/CrtCommand.3 index fcc04d5..748ff2d 100644 --- a/doc/CrtCommand.3 +++ b/doc/CrtCommand.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateCommand \- implement new commands in C diff --git a/doc/CrtFileHdlr.3 b/doc/CrtFileHdlr.3 index 5627bd4..e35020c 100644 --- a/doc/CrtFileHdlr.3 +++ b/doc/CrtFileHdlr.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateFileHandler 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks with files or devices (Unix only) diff --git a/doc/CrtInterp.3 b/doc/CrtInterp.3 index 957e742..ab44fc6 100644 --- a/doc/CrtInterp.3 +++ b/doc/CrtInterp.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpDeleted \- create and delete Tcl command interpreters diff --git a/doc/CrtMathFnc.3 b/doc/CrtMathFnc.3 index 9629912..0f101d7 100644 --- a/doc/CrtMathFnc.3 +++ b/doc/CrtMathFnc.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index a05efc2..005bf97 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C diff --git a/doc/CrtSlave.3 b/doc/CrtSlave.3 index 3863373..8457d21 100644 --- a/doc/CrtSlave.3 +++ b/doc/CrtSlave.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands diff --git a/doc/CrtTimerHdlr.3 b/doc/CrtTimerHdlr.3 index e948728..39702b1 100644 --- a/doc/CrtTimerHdlr.3 +++ b/doc/CrtTimerHdlr.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateTimerHandler 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateTimerHandler, Tcl_DeleteTimerHandler \- call a procedure at a given time diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index 076f47b..ec83c91 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced diff --git a/doc/DString.3 b/doc/DString.3 index a85b1cf..0e571d2 100644 --- a/doc/DString.3 +++ b/doc/DString.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings diff --git a/doc/DetachPids.3 b/doc/DetachPids.3 index 0535cd8..39a51d3 100644 --- a/doc/DetachPids.3 +++ b/doc/DetachPids.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DetachPids 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_DetachPids, Tcl_ReapDetachedProcs, Tcl_WaitPid \- manage child processes in background diff --git a/doc/DictObj.3 b/doc/DictObj.3 index 74b8dd1..badba69 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DictObj 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/DoOneEvent.3 b/doc/DoOneEvent.3 index 9bdf926..6f08b34 100644 --- a/doc/DoOneEvent.3 +++ b/doc/DoOneEvent.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DoOneEvent 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_DoOneEvent \- wait for events and invoke event handlers diff --git a/doc/DoWhenIdle.3 b/doc/DoWhenIdle.3 index bfc19fb..501378e 100644 --- a/doc/DoWhenIdle.3 +++ b/doc/DoWhenIdle.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DoWhenIdle 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_DoWhenIdle, Tcl_CancelIdleCall \- invoke a procedure when there are no pending events diff --git a/doc/DoubleObj.3 b/doc/DoubleObj.3 index 12818b0..a2496d9 100644 --- a/doc/DoubleObj.3 +++ b/doc/DoubleObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewDoubleObj, Tcl_SetDoubleObj, Tcl_GetDoubleFromObj \- manipulate Tcl objects as floating-point values diff --git a/doc/DumpActiveMemory.3 b/doc/DumpActiveMemory.3 index 1f6cb46..f4d78d1 100644 --- a/doc/DumpActiveMemory.3 +++ b/doc/DumpActiveMemory.3 @@ -3,8 +3,8 @@ '\" Copyright (c) 2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH "Tcl_DumpActiveMemory" 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_DumpActiveMemory, Tcl_InitMemory, Tcl_ValidateAllMemory \- Validated memory allocation interface diff --git a/doc/Encoding.3 b/doc/Encoding.3 index a940a5b..c14338d 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings diff --git a/doc/Ensemble.3 b/doc/Ensemble.3 index bc743c2..3cf3143 100644 --- a/doc/Ensemble.3 +++ b/doc/Ensemble.3 @@ -6,8 +6,8 @@ '\" '\" This documents the C API introduced in TIP#235 '\" -.so man.macros .TH Tcl_Ensemble 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateEnsemble, Tcl_FindEnsemble, Tcl_GetEnsembleFlags, Tcl_GetEnsembleMappingDict, Tcl_GetEnsembleNamespace, Tcl_GetEnsembleUnknownHandler, Tcl_GetEnsembleSubcommandList, Tcl_IsEnsemble, Tcl_SetEnsembleFlags, Tcl_SetEnsembleMappingDict, Tcl_SetEnsembleSubcommandList, Tcl_SetEnsembleUnknownHandler \- manipulate ensemble commands diff --git a/doc/Environment.3 b/doc/Environment.3 index 3753f43..dee693b 100644 --- a/doc/Environment.3 +++ b/doc/Environment.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_PutEnv 3 "7.5" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_PutEnv \- procedures to manipulate the environment diff --git a/doc/Eval.3 b/doc/Eval.3 index f232cad..92dce7c 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts diff --git a/doc/Exit.3 b/doc/Exit.3 index aa69b47..1738dbe 100644 --- a/doc/Exit.3 +++ b/doc/Exit.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Exit 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Exit, Tcl_Finalize, Tcl_CreateExitHandler, Tcl_DeleteExitHandler, Tcl_ExitThread, Tcl_FinalizeThread, Tcl_CreateThreadExitHandler, Tcl_DeleteThreadExitHandler, Tcl_SetExitProc \- end the application or thread (and invoke exit handlers) diff --git a/doc/ExprLong.3 b/doc/ExprLong.3 index ef93284..33d68ba 100644 --- a/doc/ExprLong.3 +++ b/doc/ExprLong.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression diff --git a/doc/ExprLongObj.3 b/doc/ExprLongObj.3 index c8a564d..9dd7f0b 100644 --- a/doc/ExprLongObj.3 +++ b/doc/ExprLongObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ExprLongObj 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj \- evaluate an expression diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index c4a28c2..7954ac8 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSEvalFileEx, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_AllocStatBuf \- procedures to interact with any filesystem diff --git a/doc/FindExec.3 b/doc/FindExec.3 index 0e225e9..af9d9ad 100644 --- a/doc/FindExec.3 +++ b/doc/FindExec.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_FindExecutable 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_FindExecutable, Tcl_GetNameOfExecutable \- identify or return the name of the binary file containing the application diff --git a/doc/GetCwd.3 b/doc/GetCwd.3 index 964e237..58abcde 100644 --- a/doc/GetCwd.3 +++ b/doc/GetCwd.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetCwd 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetCwd, Tcl_Chdir \- manipulate the current working directory diff --git a/doc/GetHostName.3 b/doc/GetHostName.3 index 28f3a4f..8aed0dc 100644 --- a/doc/GetHostName.3 +++ b/doc/GetHostName.3 @@ -2,8 +2,8 @@ '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH Tcl_GetHostName 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetHostName \- get the name of the local host diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 45d4e9c..88cd98b 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetIndexFromObj 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct \- lookup string in table of keywords diff --git a/doc/GetInt.3 b/doc/GetInt.3 index f77d337..4e9d636 100644 --- a/doc/GetInt.3 +++ b/doc/GetInt.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetInt 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean diff --git a/doc/GetOpnFl.3 b/doc/GetOpnFl.3 index 38aa976..86d1b94 100644 --- a/doc/GetOpnFl.3 +++ b/doc/GetOpnFl.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetOpenFile 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetOpenFile \- Return a FILE* for a channel registered in the given interpreter (Unix only) diff --git a/doc/GetStdChan.3 b/doc/GetStdChan.3 index 045d15a..a7d9501 100644 --- a/doc/GetStdChan.3 +++ b/doc/GetStdChan.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetStdChannel 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/GetTime.3 b/doc/GetTime.3 index 14a9e8c..a617451 100644 --- a/doc/GetTime.3 +++ b/doc/GetTime.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetTime 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetTime, Tcl_SetTimeProc, Tcl_QueryTimeProc \- get date and time diff --git a/doc/GetVersion.3 b/doc/GetVersion.3 index 47034d0..89f63d5 100644 --- a/doc/GetVersion.3 +++ b/doc/GetVersion.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetVersion 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetVersion \- get the version of the library at runtime diff --git a/doc/Hash.3 b/doc/Hash.3 index 78b8459..6babe0d 100644 --- a/doc/Hash.3 +++ b/doc/Hash.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables diff --git a/doc/Init.3 b/doc/Init.3 index f421479..33c27a3 100644 --- a/doc/Init.3 +++ b/doc/Init.3 @@ -2,8 +2,8 @@ '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Init \- find and source initialization script diff --git a/doc/InitStubs.3 b/doc/InitStubs.3 index fe10a59..f4be477 100644 --- a/doc/InitStubs.3 +++ b/doc/InitStubs.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_InitStubs 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_InitStubs \- initialize the Tcl stubs mechanism diff --git a/doc/IntObj.3 b/doc/IntObj.3 index 5cf677d..e228bdb 100644 --- a/doc/IntObj.3 +++ b/doc/IntObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl objects as integer values diff --git a/doc/Interp.3 b/doc/Interp.3 index 0b1de03..10aadb7 100644 --- a/doc/Interp.3 +++ b/doc/Interp.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Interp 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Interp \- client-visible fields of interpreter structures diff --git a/doc/Limit.3 b/doc/Limit.3 index 928ebe1..a113b74 100644 --- a/doc/Limit.3 +++ b/doc/Limit.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_LimitCheck 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_LimitAddHandler, Tcl_LimitCheck, Tcl_LimitExceeded, Tcl_LimitGetCommands, Tcl_LimitGetGranularity, Tcl_LimitGetTime, Tcl_LimitReady, Tcl_LimitRemoveHandler, Tcl_LimitSetCommands, Tcl_LimitSetGranularity, Tcl_LimitSetTime, Tcl_LimitTypeEnabled, Tcl_LimitTypeExceeded, Tcl_LimitTypeReset, Tcl_LimitTypeSet \- manage and check resource limits on interpreters diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index 6361fb4..9c13008 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable diff --git a/doc/ListObj.3 b/doc/ListObj.3 index 443eafe..c0cc109 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl objects as lists diff --git a/doc/Namespace.3 b/doc/Namespace.3 index 5477329..4b37c2b 100644 --- a/doc/Namespace.3 +++ b/doc/Namespace.3 @@ -7,8 +7,8 @@ '\" Note that some of these functions do not seem to belong, but they '\" were all introduced with the same TIP (#139) '\" -.so man.macros .TH Tcl_Namespace 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_AppendExportList, Tcl_CreateNamespace, Tcl_DeleteNamespace, Tcl_Export, Tcl_FindCommand, Tcl_FindNamespace, Tcl_ForgetImport, Tcl_GetCurrentNamespace, Tcl_GetGlobalNamespace, Tcl_GetNamespaceUnknownHandler, Tcl_Import, Tcl_SetNamespaceUnknownHandler \- manipulate namespaces diff --git a/doc/Notifier.3 b/doc/Notifier.3 index 7858a8c..9edf069 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Notifier 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces diff --git a/doc/Object.3 b/doc/Object.3 index 4817b9b..4df6c1a 100644 --- a/doc/Object.3 +++ b/doc/Object.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl objects diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index 974ea6c..0a5de3d 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl object types diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index 0d722f6..10c92f6 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/OpenTcp.3 b/doc/OpenTcp.3 index 98d8cb0..ec7edcd 100644 --- a/doc/OpenTcp.3 +++ b/doc/OpenTcp.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_OpenTcpClient 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/Panic.3 b/doc/Panic.3 index b53ca11..454d313 100644 --- a/doc/Panic.3 +++ b/doc/Panic.3 @@ -2,8 +2,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3 index b5fc6d0..ff1be23 100644 --- a/doc/ParseCmd.3 +++ b/doc/ParseCmd.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions diff --git a/doc/PkgRequire.3 b/doc/PkgRequire.3 index 810947d..b7d0e6e 100644 --- a/doc/PkgRequire.3 +++ b/doc/PkgRequire.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_PkgRequire 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_PkgRequire, Tcl_PkgRequireEx, Tcl_PkgRequireProc, Tcl_PkgPresent, Tcl_PkgPresentEx, Tcl_PkgProvide, Tcl_PkgProvideEx \- package version control diff --git a/doc/Preserve.3 b/doc/Preserve.3 index 2b3edc0..5b808cd 100644 --- a/doc/Preserve.3 +++ b/doc/Preserve.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Preserve 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Preserve, Tcl_Release, Tcl_EventuallyFree \- avoid freeing storage while it is being used diff --git a/doc/PrintDbl.3 b/doc/PrintDbl.3 index 279b4d5..508b230 100644 --- a/doc/PrintDbl.3 +++ b/doc/PrintDbl.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_PrintDouble 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_PrintDouble \- Convert floating value to string diff --git a/doc/RecEvalObj.3 b/doc/RecEvalObj.3 index 2eed471..f0bb183 100644 --- a/doc/RecEvalObj.3 +++ b/doc/RecEvalObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_RecordAndEvalObj 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_RecordAndEvalObj \- save command on history list before evaluating diff --git a/doc/RecordEval.3 b/doc/RecordEval.3 index a8f3087..f4a403e 100644 --- a/doc/RecordEval.3 +++ b/doc/RecordEval.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_RecordAndEval 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_RecordAndEval \- save command on history list before evaluating diff --git a/doc/RegConfig.3 b/doc/RegConfig.3 index 19c0bb0..7f99b8f 100644 --- a/doc/RegConfig.3 +++ b/doc/RegConfig.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_RegisterConfig 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/RegExp.3 b/doc/RegExp.3 index 0ac091c..c337cf8 100644 --- a/doc/RegExp.3 +++ b/doc/RegExp.3 @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange, Tcl_GetRegExpFromObj, Tcl_RegExpMatchObj, Tcl_RegExpExecObj, Tcl_RegExpGetInfo \- Pattern matching with regular expressions diff --git a/doc/SaveResult.3 b/doc/SaveResult.3 index f47500e..74da9f4 100644 --- a/doc/SaveResult.3 +++ b/doc/SaveResult.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's state diff --git a/doc/SetChanErr.3 b/doc/SetChanErr.3 index 13bd94a..aded11e 100644 --- a/doc/SetChanErr.3 +++ b/doc/SetChanErr.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetChannelError 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/SetErrno.3 b/doc/SetErrno.3 index 1735952..21648b1 100644 --- a/doc/SetErrno.3 +++ b/doc/SetErrno.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetErrno 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SetErrno, Tcl_GetErrno, Tcl_ErrnoId, Tcl_ErrnoMsg \- manipulate errno to store and retrieve error codes diff --git a/doc/SetRecLmt.3 b/doc/SetRecLmt.3 index e38ba2f..904d4ab 100644 --- a/doc/SetRecLmt.3 +++ b/doc/SetRecLmt.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetRecursionLimit 3 7.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter diff --git a/doc/SetResult.3 b/doc/SetResult.3 index 2245794..4bb9101 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result diff --git a/doc/SetVar.3 b/doc/SetVar.3 index ce47a73..e0eb51e 100644 --- a/doc/SetVar.3 +++ b/doc/SetVar.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetVar 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SetVar2Ex, Tcl_SetVar, Tcl_SetVar2, Tcl_ObjSetVar2, Tcl_GetVar2Ex, Tcl_GetVar, Tcl_GetVar2, Tcl_ObjGetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables diff --git a/doc/Signal.3 b/doc/Signal.3 index 5b12654..70b9d91 100644 --- a/doc/Signal.3 +++ b/doc/Signal.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SignalId 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SignalId, Tcl_SignalMsg \- Convert signal codes diff --git a/doc/Sleep.3 b/doc/Sleep.3 index 2423ba1..2d36697 100644 --- a/doc/Sleep.3 +++ b/doc/Sleep.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Sleep 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Sleep \- delay execution for a given number of milliseconds diff --git a/doc/SourceRCFile.3 b/doc/SourceRCFile.3 index eabc47c..0afb66b 100644 --- a/doc/SourceRCFile.3 +++ b/doc/SourceRCFile.3 @@ -2,8 +2,8 @@ '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH Tcl_SourceRCFile 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SourceRCFile \- source the Tcl rc file diff --git a/doc/SplitList.3 b/doc/SplitList.3 index fd6ec8b..0fefc8b 100644 --- a/doc/SplitList.3 +++ b/doc/SplitList.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SplitList 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SplitList, Tcl_Merge, Tcl_ScanElement, Tcl_ConvertElement, Tcl_ScanCountedElement, Tcl_ConvertCountedElement \- manipulate Tcl lists diff --git a/doc/SplitPath.3 b/doc/SplitPath.3 index 6578e3d..6863b6f 100644 --- a/doc/SplitPath.3 +++ b/doc/SplitPath.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SplitPath 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SplitPath, Tcl_JoinPath, Tcl_GetPathType \- manipulate platform-dependent file paths diff --git a/doc/StaticPkg.3 b/doc/StaticPkg.3 index 0dd67d1..0b2ad57 100644 --- a/doc/StaticPkg.3 +++ b/doc/StaticPkg.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_StaticPackage 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_StaticPackage \- make a statically linked package available via the 'load' command diff --git a/doc/StdChannels.3 b/doc/StdChannels.3 index b5b020e..651ad7d 100644 --- a/doc/StdChannels.3 +++ b/doc/StdChannels.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "Standard Channels" 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/StrMatch.3 b/doc/StrMatch.3 index 5adaf6e..f9c2be3 100644 --- a/doc/StrMatch.3 +++ b/doc/StrMatch.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_StringMatch 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_StringMatch, Tcl_StringCaseMatch \- test whether a string matches a pattern diff --git a/doc/StringObj.3 b/doc/StringObj.3 index e451c61..47f597c 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl objects as strings diff --git a/doc/SubstObj.3 b/doc/SubstObj.3 index 786b595..ba0ee7c 100644 --- a/doc/SubstObj.3 +++ b/doc/SubstObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SubstObj 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SubstObj \- perform substitutions on Tcl objects diff --git a/doc/TCL_MEM_DEBUG.3 b/doc/TCL_MEM_DEBUG.3 index 5a3e08a..e3a6809 100644 --- a/doc/TCL_MEM_DEBUG.3 +++ b/doc/TCL_MEM_DEBUG.3 @@ -3,8 +3,8 @@ '\" Copyright (c) 2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH TCL_MEM_DEBUG 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME TCL_MEM_DEBUG \- Compile-time flag to enable Tcl memory debugging diff --git a/doc/Tcl.n b/doc/Tcl.n index 8b5b501..980d81f 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl n "8.5" Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME Tcl \- Tool Command Language diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 54b2e84..4b4ceb7 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Main, Tcl_SetMainLoop \- main program and event loop definition for Tcl-based applications diff --git a/doc/Thread.3 b/doc/Thread.3 index 80d34ad..5517a41 100644 --- a/doc/Thread.3 +++ b/doc/Thread.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Threads 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread, Tcl_JoinThread \- Tcl thread support diff --git a/doc/ToUpper.3 b/doc/ToUpper.3 index d6b3006..587e76b 100644 --- a/doc/ToUpper.3 +++ b/doc/ToUpper.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_UtfToUpper 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_UtfToLower, Tcl_UtfToTitle \- routines for manipulating the case of Unicode characters and UTF-8 strings diff --git a/doc/TraceCmd.3 b/doc/TraceCmd.3 index 020f1ca..b15face 100644 --- a/doc/TraceCmd.3 +++ b/doc/TraceCmd.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_TraceCommand 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index f80d86f..97af6d4 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable diff --git a/doc/Translate.3 b/doc/Translate.3 index d434cda..7b8acc9 100644 --- a/doc/Translate.3 +++ b/doc/Translate.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_TranslateFileName 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_TranslateFileName \- convert file name to native form and replace tilde with home directory diff --git a/doc/UniCharIsAlpha.3 b/doc/UniCharIsAlpha.3 index 6029b2d..ea6fc5b 100644 --- a/doc/UniCharIsAlpha.3 +++ b/doc/UniCharIsAlpha.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_UniCharIsAlpha 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, Tcl_UniCharIsControl, Tcl_UniCharIsDigit, Tcl_UniCharIsGraph, Tcl_UniCharIsLower, Tcl_UniCharIsPrint, Tcl_UniCharIsPunct, Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar \- routines for classification of Tcl_UniChar characters diff --git a/doc/UpVar.3 b/doc/UpVar.3 index f1e6fe4..8e7ba08 100644 --- a/doc/UpVar.3 +++ b/doc/UpVar.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_UpVar 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_UpVar, Tcl_UpVar2 \- link one variable to another diff --git a/doc/Utf.3 b/doc/Utf.3 index 8e39fef..cfd587c 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Utf 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_UniChar, Tcl_UniCharCaseMatch, Tcl_UniCharNcasecmp, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings diff --git a/doc/WrongNumArgs.3 b/doc/WrongNumArgs.3 index 2175858..f24cba5 100644 --- a/doc/WrongNumArgs.3 +++ b/doc/WrongNumArgs.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_WrongNumArgs 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_WrongNumArgs \- generate standard error message for wrong number of arguments diff --git a/doc/after.n b/doc/after.n index 21961d3..2a5d005 100644 --- a/doc/after.n +++ b/doc/after.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH after n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/append.n b/doc/append.n index dc9adbe..b0b8216 100644 --- a/doc/append.n +++ b/doc/append.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH append n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/apply.n b/doc/apply.n index 8a38aac..003621e 100644 --- a/doc/apply.n +++ b/doc/apply.n @@ -2,8 +2,8 @@ '\" Copyright (c) 2006 Miguel Sofer '\" Copyright (c) 2006 Donal K. Fellows '\" -.so man.macros .TH apply n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/array.n b/doc/array.n index e112c23..056992c 100644 --- a/doc/array.n +++ b/doc/array.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH array n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/bgerror.n b/doc/bgerror.n index cb91351..da854f2 100644 --- a/doc/bgerror.n +++ b/doc/bgerror.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH bgerror n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/binary.n b/doc/binary.n index 6b2150e..ff800f0 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH binary n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/break.n b/doc/break.n index ed09c03..e364204 100644 --- a/doc/break.n +++ b/doc/break.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH break n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/case.n b/doc/case.n index 0155a61..54d5bf4 100644 --- a/doc/case.n +++ b/doc/case.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH case n 7.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/catch.n b/doc/catch.n index 0e2ec04..ada0fe7 100644 --- a/doc/catch.n +++ b/doc/catch.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH catch n "8.5" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/cd.n b/doc/cd.n index 191fb62..d6b0aa0 100644 --- a/doc/cd.n +++ b/doc/cd.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH cd n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/chan.n b/doc/chan.n index f5d3d54..e8356e2 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -3,8 +3,8 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -.so man.macros .TH chan n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/clock.n b/doc/clock.n index 600722b..7c4c3df 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -2,8 +2,8 @@ '\" Generated from file './doc/clock.dt' by tcllib/doctools with format 'nroff' '\" Copyright (c) 2004 Kevin B. Kenny . All rights reserved. '\" -.so man.macros .TH "clock" n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME clock \- Obtain and manipulate dates and times diff --git a/doc/close.n b/doc/close.n index 4ef3c7d..639fddb 100644 --- a/doc/close.n +++ b/doc/close.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH close n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/concat.n b/doc/concat.n index f7317c4..252f52c 100644 --- a/doc/concat.n +++ b/doc/concat.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH concat n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/continue.n b/doc/continue.n index 221b7e2..728b9dc 100644 --- a/doc/continue.n +++ b/doc/continue.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH continue n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/dde.n b/doc/dde.n index 2e3c883..06de949 100644 --- a/doc/dde.n +++ b/doc/dde.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH dde n 1.3 dde "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/dict.n b/doc/dict.n index 28c4f7c..4a107d3 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH dict n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/encoding.n b/doc/encoding.n index f8f3d54..1c0bfa9 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH encoding n "8.1" Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME encoding \- Manipulate encodings diff --git a/doc/eof.n b/doc/eof.n index 14cf8f9..f382fdf 100644 --- a/doc/eof.n +++ b/doc/eof.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH eof n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/error.n b/doc/error.n index 77391e5..ff01a6f 100644 --- a/doc/error.n +++ b/doc/error.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH error n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/eval.n b/doc/eval.n index a642d23..d68db95 100644 --- a/doc/eval.n +++ b/doc/eval.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH eval n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/exec.n b/doc/exec.n index fd4e9cf..3857a71 100644 --- a/doc/exec.n +++ b/doc/exec.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH exec n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/exit.n b/doc/exit.n index eccd635..cce449f 100644 --- a/doc/exit.n +++ b/doc/exit.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH exit n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/expr.n b/doc/expr.n index dbc9026..6c83504 100644 --- a/doc/expr.n +++ b/doc/expr.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH expr n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/fblocked.n b/doc/fblocked.n index d8e8af7..fbe244f 100644 --- a/doc/fblocked.n +++ b/doc/fblocked.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/fconfigure.n b/doc/fconfigure.n index 0763232..51778c3 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH fconfigure n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/fcopy.n b/doc/fcopy.n index d583cf0..290ec49 100644 --- a/doc/fcopy.n +++ b/doc/fcopy.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH fcopy n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/file.n b/doc/file.n index b62d252..36eae79 100644 --- a/doc/file.n +++ b/doc/file.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH file n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/fileevent.n b/doc/fileevent.n index eb555f5..c1cea3a 100644 --- a/doc/fileevent.n +++ b/doc/fileevent.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/filename.n b/doc/filename.n index 1fe22f0..e5f939b 100644 --- a/doc/filename.n +++ b/doc/filename.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH filename n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/flush.n b/doc/flush.n index 1c79ea0..4a9ef15 100644 --- a/doc/flush.n +++ b/doc/flush.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH flush n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/for.n b/doc/for.n index 033903f..9773677 100644 --- a/doc/for.n +++ b/doc/for.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH for n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/foreach.n b/doc/foreach.n index 654c0cf..1a3b2b6 100644 --- a/doc/foreach.n +++ b/doc/foreach.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH foreach n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/format.n b/doc/format.n index f842f16..8456e28 100644 --- a/doc/format.n +++ b/doc/format.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH format n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/gets.n b/doc/gets.n index bed7e32..fd1b87a 100644 --- a/doc/gets.n +++ b/doc/gets.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH gets n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/glob.n b/doc/glob.n index c257983..701a623 100644 --- a/doc/glob.n +++ b/doc/glob.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH glob n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/global.n b/doc/global.n index c9d7a36..34db146 100644 --- a/doc/global.n +++ b/doc/global.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH global n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/history.n b/doc/history.n index ba507b4..e1f9781 100644 --- a/doc/history.n +++ b/doc/history.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH history n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/http.n b/doc/http.n index 24b5f6a..8aeb286 100644 --- a/doc/http.n +++ b/doc/http.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "http" n 2.7 http "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/if.n b/doc/if.n index d84cf08..085d3fe 100644 --- a/doc/if.n +++ b/doc/if.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH if n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/incr.n b/doc/incr.n index 72b3ff8..46c80a1 100644 --- a/doc/incr.n +++ b/doc/incr.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH incr n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/info.n b/doc/info.n index fae0d43..8008c57 100644 --- a/doc/info.n +++ b/doc/info.n @@ -7,8 +7,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/interp.n b/doc/interp.n index c753ee9..d9ce0c4 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH interp n 7.6 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/join.n b/doc/join.n index 582b730..270f9f3 100644 --- a/doc/join.n +++ b/doc/join.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH join n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lappend.n b/doc/lappend.n index dbed3bb..5619272 100644 --- a/doc/lappend.n +++ b/doc/lappend.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lappend n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lassign.n b/doc/lassign.n index b791feb..7b3bcdc 100644 --- a/doc/lassign.n +++ b/doc/lassign.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lassign n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/library.n b/doc/library.n index f29af8b..e9f81ac 100644 --- a/doc/library.n +++ b/doc/library.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH library n "8.0" Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME auto_execok, auto_import, auto_load, auto_mkindex, auto_mkindex_old, auto_qualify, auto_reset, tcl_findLibrary, parray, tcl_endOfWord, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore \- standard library of Tcl procedures diff --git a/doc/lindex.n b/doc/lindex.n index f0417ac..1482807 100644 --- a/doc/lindex.n +++ b/doc/lindex.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lindex n 8.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/linsert.n b/doc/linsert.n index 9f37fcd..d73a05a 100644 --- a/doc/linsert.n +++ b/doc/linsert.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH linsert n 8.2 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/list.n b/doc/list.n index 2bcdafb..993987e 100644 --- a/doc/list.n +++ b/doc/list.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH list n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/llength.n b/doc/llength.n index 627800f..d3d7e14 100644 --- a/doc/llength.n +++ b/doc/llength.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH llength n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/load.n b/doc/load.n index e5501f6..e028642 100644 --- a/doc/load.n +++ b/doc/load.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lrange.n b/doc/lrange.n index 34f0150..66345c6 100644 --- a/doc/lrange.n +++ b/doc/lrange.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lrange n 7.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lrepeat.n b/doc/lrepeat.n index ac78690..848255b 100644 --- a/doc/lrepeat.n +++ b/doc/lrepeat.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lrepeat n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lreplace.n b/doc/lreplace.n index 2cd79d8..18c6490 100644 --- a/doc/lreplace.n +++ b/doc/lreplace.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lreplace n 7.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lreverse.n b/doc/lreverse.n index da5e489..48886be 100644 --- a/doc/lreverse.n +++ b/doc/lreverse.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lreverse n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lsearch.n b/doc/lsearch.n index b046ba2..f7c4976 100644 --- a/doc/lsearch.n +++ b/doc/lsearch.n @@ -7,8 +7,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lsearch n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lset.n b/doc/lset.n index 5efcbae..c191ebf 100644 --- a/doc/lset.n +++ b/doc/lset.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lset n 8.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lsort.n b/doc/lsort.n index 1726e92..cf0f0ca 100644 --- a/doc/lsort.n +++ b/doc/lsort.n @@ -7,8 +7,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lsort n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/mathfunc.n b/doc/mathfunc.n index 4ba25e4..c5ef6e0 100644 --- a/doc/mathfunc.n +++ b/doc/mathfunc.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH mathfunc n 8.5 Tcl "Tcl Mathematical Functions" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/mathop.n b/doc/mathop.n index 5757f87..1ddd86e 100644 --- a/doc/mathop.n +++ b/doc/mathop.n @@ -4,8 +4,8 @@ .\" See the file "license.terms" for information on usage and redistribution .\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. .\" -.so man.macros .TH mathop n 8.5 Tcl "Tcl Mathematical Operator Commands" +.so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/memory.n b/doc/memory.n index 4ff681d..92e67c8 100644 --- a/doc/memory.n +++ b/doc/memory.n @@ -3,8 +3,8 @@ '\" Copyright (c) 2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH memory n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME memory \- Control Tcl memory debugging capabilities diff --git a/doc/msgcat.n b/doc/msgcat.n index bfd94ae..bae6dbe 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/namespace.n b/doc/namespace.n index 8b26786..866db1b 100644 --- a/doc/namespace.n +++ b/doc/namespace.n @@ -7,8 +7,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH namespace n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/open.n b/doc/open.n index 88283bb..b888126 100644 --- a/doc/open.n +++ b/doc/open.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH open n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/package.n b/doc/package.n index d4fe657..dd1fc36 100644 --- a/doc/package.n +++ b/doc/package.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH package n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/packagens.n b/doc/packagens.n index 1220b20..1152314 100644 --- a/doc/packagens.n +++ b/doc/packagens.n @@ -2,8 +2,8 @@ '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH pkg::create n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/pid.n b/doc/pid.n index 97a42a7..a4df2f3 100644 --- a/doc/pid.n +++ b/doc/pid.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH pid n 7.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/pkgMkIndex.n b/doc/pkgMkIndex.n index 5895407..d5cab7b 100644 --- a/doc/pkgMkIndex.n +++ b/doc/pkgMkIndex.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/platform.n b/doc/platform.n index 053448d..7233215 100644 --- a/doc/platform.n +++ b/doc/platform.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "platform" n 1.0.4 platform "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/platform_shell.n b/doc/platform_shell.n index eef4d4e..64a2e46 100644 --- a/doc/platform_shell.n +++ b/doc/platform_shell.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "platform::shell" n 1.1.4 platform::shell "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/proc.n b/doc/proc.n index 4525207..0f8cc04 100644 --- a/doc/proc.n +++ b/doc/proc.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH proc n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/puts.n b/doc/puts.n index 5cd8721..7dbfa5e 100644 --- a/doc/puts.n +++ b/doc/puts.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH puts n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/pwd.n b/doc/pwd.n index e63b815..423a263 100644 --- a/doc/pwd.n +++ b/doc/pwd.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH pwd n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/re_syntax.n b/doc/re_syntax.n index 8701641..a74746a 100644 --- a/doc/re_syntax.n +++ b/doc/re_syntax.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME re_syntax \- Syntax of Tcl regular expressions diff --git a/doc/read.n b/doc/read.n index 5398b08..6e614f2 100644 --- a/doc/read.n +++ b/doc/read.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH read n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/refchan.n b/doc/refchan.n index 577c78a..d27e464 100644 --- a/doc/refchan.n +++ b/doc/refchan.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH refchan n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/regexp.n b/doc/regexp.n index 100f0d8..db53897 100644 --- a/doc/regexp.n +++ b/doc/regexp.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH regexp n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/registry.n b/doc/registry.n index e4371e6..927af16 100644 --- a/doc/registry.n +++ b/doc/registry.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH registry n 1.1 registry "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/regsub.n b/doc/regsub.n index 5adfd61..90e7d88 100644 --- a/doc/regsub.n +++ b/doc/regsub.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH regsub n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/rename.n b/doc/rename.n index c207523..0633710 100644 --- a/doc/rename.n +++ b/doc/rename.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH rename n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/return.n b/doc/return.n index b08de4a..b7f928a 100644 --- a/doc/return.n +++ b/doc/return.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH return n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/safe.n b/doc/safe.n index 590f2c6..9ecc9a0 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/scan.n b/doc/scan.n index 4ee9a59..7a84499 100644 --- a/doc/scan.n +++ b/doc/scan.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH scan n 8.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/seek.n b/doc/seek.n index d4ce9b7..9214f8e 100644 --- a/doc/seek.n +++ b/doc/seek.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH seek n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/set.n b/doc/set.n index fb8dfac..5e13713 100644 --- a/doc/set.n +++ b/doc/set.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH set n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/socket.n b/doc/socket.n index c020839..7050429 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH socket n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/source.n b/doc/source.n index 69d383e..9f0fd6f 100644 --- a/doc/source.n +++ b/doc/source.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH source n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/split.n b/doc/split.n index c289be0..70bf129 100644 --- a/doc/split.n +++ b/doc/split.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH split n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/string.n b/doc/string.n index e74b8a2..f39d57c 100644 --- a/doc/string.n +++ b/doc/string.n @@ -5,8 +5,8 @@ .\" See the file "license.terms" for information on usage and redistribution .\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. .\" -.so man.macros .TH string n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/subst.n b/doc/subst.n index 5a162c4..07f0933 100644 --- a/doc/subst.n +++ b/doc/subst.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH subst n 7.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/switch.n b/doc/switch.n index defa849..1c4dd74 100644 --- a/doc/switch.n +++ b/doc/switch.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH switch n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/tclsh.1 b/doc/tclsh.1 index d9fe95e..d40ac55 100644 --- a/doc/tclsh.1 +++ b/doc/tclsh.1 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/tcltest.n b/doc/tcltest.n index 9ac8f66..399a673 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -8,8 +8,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/tclvars.n b/doc/tclvars.n index 885de34..b3e1bee 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/tell.n b/doc/tell.n index 282cae5..c3f8db8 100644 --- a/doc/tell.n +++ b/doc/tell.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH tell n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/time.n b/doc/time.n index bdd0786..b734c6a 100644 --- a/doc/time.n +++ b/doc/time.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH time n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/tm.n b/doc/tm.n index aef06dd..edd6cff 100644 --- a/doc/tm.n +++ b/doc/tm.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH tm n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/trace.n b/doc/trace.n index c928856..97fbdba 100644 --- a/doc/trace.n +++ b/doc/trace.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH trace n "8.4" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/unknown.n b/doc/unknown.n index c258daa..15f903d 100644 --- a/doc/unknown.n +++ b/doc/unknown.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH unknown n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/unload.n b/doc/unload.n index f060cd6..82c4f4a 100644 --- a/doc/unload.n +++ b/doc/unload.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH unload n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/unset.n b/doc/unset.n index 29d7e7c..09f2ce6 100644 --- a/doc/unset.n +++ b/doc/unset.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH unset n 8.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/update.n b/doc/update.n index 555766c..745c5fd 100644 --- a/doc/update.n +++ b/doc/update.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH update n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/uplevel.n b/doc/uplevel.n index c8ef0ff..074f822 100644 --- a/doc/uplevel.n +++ b/doc/uplevel.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH uplevel n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/upvar.n b/doc/upvar.n index a255485..91db24a 100644 --- a/doc/upvar.n +++ b/doc/upvar.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH upvar n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/variable.n b/doc/variable.n index 3a60485..6400c23 100644 --- a/doc/variable.n +++ b/doc/variable.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH variable n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/vwait.n b/doc/vwait.n index e7289e1..f516d46 100644 --- a/doc/vwait.n +++ b/doc/vwait.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH vwait n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/while.n b/doc/while.n index 33aa415..da49853 100644 --- a/doc/while.n +++ b/doc/while.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH while n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -- cgit v0.12 From 498d86acd9ca0d9d7bc004c1c14c19dc332b77a3 Mon Sep 17 00:00:00 2001 From: max Date: Tue, 12 Nov 2013 11:45:04 +0000 Subject: Fix [5425f2c082]: [fconfigure -error] breaks the background processing of a pending [socket -async]. --- tests/socket.test | 28 ++++++++++++++++++++++++++++ unix/tclUnixSock.c | 19 ++++++++++++++----- 2 files changed, 42 insertions(+), 5 deletions(-) diff --git a/tests/socket.test b/tests/socket.test index 5542c09..f7e817b 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1841,6 +1841,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ after cancel $after close $client close $server + unset x } -result {{} bye} test socket-14.5 {[socket -async] which fails before any connect() can be made} \ -constraints [list socket supported_any] \ @@ -1850,6 +1851,33 @@ test socket-14.5 {[socket -async] which fails before any connect() can be made} } \ -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} +test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \ + -constraints [list socket supported_any] \ + -setup { + proc accept {s a p} { + puts $s bye + close $s + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + foreach _ {1 2} { + lappend x [lindex [fconfigure $client -sockname] 0] + lappend x [fconfigure $client -error] + update + } + lappend x [gets $client] + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result [list ::1 "connection refused" 127.0.0.1 "" bye] + ::tcltest::cleanupTests flush stdout return diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index a6360c2..7ef28d8 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -737,7 +737,10 @@ TcpGetOptionProc( if (statePtr->status == 0) { ret = getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, - (char *) &err, &optlen); + (char *) &err, &optlen); + if (statePtr->flags & TCP_ASYNC_CONNECT) { + statePtr->status = err; + } if (ret < 0) { err = errno; } @@ -1054,12 +1057,17 @@ CreateClientSocket( */ optlen = sizeof(int); - getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR, - (char *) &status, &optlen); - state->status = status; + + if (state->status == 0) { + getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR, + (char *) &status, &optlen); + state->status = status; + } else { + status = state->status; + state->status = 0; + } } if (status == 0) { - CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT); goto out; } } @@ -1067,6 +1075,7 @@ CreateClientSocket( out: + CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT); if (async_callback) { /* * An asynchonous connection has finally succeeded or failed. -- cgit v0.12 From 68a9570548ce0893129ab3c5a19b38bfd3eb99fb Mon Sep 17 00:00:00 2001 From: max Date: Tue, 12 Nov 2013 13:12:21 +0000 Subject: socket-14.6 only makes sense where both, IPv4 and IPv6 are supported. --- tests/socket.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/socket.test b/tests/socket.test index f7e817b..51219e6 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1852,7 +1852,7 @@ test socket-14.5 {[socket -async] which fails before any connect() can be made} -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \ - -constraints [list socket supported_any] \ + -constraints [list socket supported_inet supported_inet6] \ -setup { proc accept {s a p} { puts $s bye -- cgit v0.12 From 729e8b44d736e3ca4af72adb070a8b89cf6fb94e Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 12 Nov 2013 15:43:55 +0000 Subject: [528717] Slight rewording to clarify what the evaluation steps are. --- doc/Tcl.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Tcl.n b/doc/Tcl.n index be0b24d..e868388 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -28,7 +28,7 @@ First, the Tcl interpreter breaks the command into \fIwords\fR and performs substitutions as described below. These substitutions are performed in the same way for all commands. -The first word is used to locate a command procedure to +Secondly, first word is used to locate a command procedure to carry out the command, then all of the words of the command are passed to the command procedure. The command procedure is free to interpret each of its words -- cgit v0.12 From dffcad90e2d661e520f735c824ddff5f1d630ddd Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 12 Nov 2013 15:47:21 +0000 Subject: Grammar check... --- doc/Tcl.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Tcl.n b/doc/Tcl.n index e868388..8b17f93 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -28,7 +28,7 @@ First, the Tcl interpreter breaks the command into \fIwords\fR and performs substitutions as described below. These substitutions are performed in the same way for all commands. -Secondly, first word is used to locate a command procedure to +Secondly, the first word is used to locate a command procedure to carry out the command, then all of the words of the command are passed to the command procedure. The command procedure is free to interpret each of its words -- cgit v0.12 From 1cc85db9fe34f20eb5109b58d4d5bd0d65140129 Mon Sep 17 00:00:00 2001 From: max Date: Fri, 15 Nov 2013 16:13:53 +0000 Subject: Don't leak getaddrinfo() results --- win/tclWinSock.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index f4d5a90..84a33ea 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1359,10 +1359,10 @@ CreateSocket( } error: - if (addrlist == NULL) { + if (addrlist != NULL) { freeaddrinfo(addrlist); } - if (myaddrlist == NULL) { + if (myaddrlist != NULL) { freeaddrinfo(myaddrlist); } -- cgit v0.12 From 4638909b08044425c05cc87efd7713ad9c6be4de Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 16 Nov 2013 20:33:17 +0000 Subject: Map WSAEWOULDBLOCK to EWOULDBLOCK. Suggested by Reinhard Max. --- win/tclWinConsole.c | 4 ++-- win/tclWinError.c | 2 +- win/tclWinPipe.c | 6 +++--- win/tclWinSerial.c | 4 ++-- win/tclWinSock.c | 6 +++--- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 65e4aed..0ec22c5 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -800,7 +800,7 @@ ConsoleOutputProc( * the channel is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; goto error; } @@ -1079,7 +1079,7 @@ WaitForRead( * is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; return -1; } diff --git a/win/tclWinError.c b/win/tclWinError.c index 49eeed3..4d3250d 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -292,7 +292,7 @@ static const unsigned char errorTable[] = { */ static const unsigned char wsaErrorTable[] = { - EAGAIN, /* WSAEWOULDBLOCK */ + EWOULDBLOCK, /* WSAEWOULDBLOCK */ EINPROGRESS, /* WSAEINPROGRESS */ EALREADY, /* WSAEALREADY */ ENOTSOCK, /* WSAENOTSOCK */ diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 13caba9..77fc776 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -1884,7 +1884,7 @@ PipeClose2Proc( SetEvent(pipePtr->stopWriter); if (WaitForSingleObject(pipePtr->writable, 0) == WAIT_TIMEOUT) { - return EAGAIN; + return EWOULDBLOCK; } } else { @@ -2161,7 +2161,7 @@ PipeOutputProc( * the channel is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; goto error; } @@ -2712,7 +2712,7 @@ WaitForRead( * is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; return -1; } diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 75d5ffc..b9c9a9f 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -932,7 +932,7 @@ SerialInputProc( bufSize = cStat.cbInQue; } } else { - errno = *errorCode = EAGAIN; + errno = *errorCode = EWOULDBLOCK; return -1; } } else { @@ -1034,7 +1034,7 @@ SerialOutputProc( * the channel is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; goto error1; } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 84a33ea..00df85f 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1318,7 +1318,7 @@ CreateSocket( if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); - if (Tcl_GetErrno() != EAGAIN) { + if (Tcl_GetErrno() != EWOULDBLOCK) { goto looperror; } @@ -1441,7 +1441,7 @@ WaitForSocketEvent( } else if (infoPtr->readyEvents & events) { break; } else if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EAGAIN; + *errorCodePtr = EWOULDBLOCK; result = 0; break; } @@ -1926,7 +1926,7 @@ TcpOutputProc( if (error == WSAEWOULDBLOCK) { infoPtr->readyEvents &= ~(FD_WRITE); if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EAGAIN; + *errorCodePtr = EWOULDBLOCK; bytesWritten = -1; break; } -- cgit v0.12 From 0507a702179a76c4f004e5321dc5f5daa0604080 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 16 Nov 2013 21:05:38 +0000 Subject: Fix [e832d2b08]: unnecessary code in Tcl_SetMaxBlockTime. --- generic/tclNotify.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/generic/tclNotify.c b/generic/tclNotify.c index f85fb7a..b45539a 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -820,11 +820,7 @@ Tcl_SetMaxBlockTime( */ if (!tsdPtr->inTraversal) { - if (tsdPtr->blockTimeSet) { - Tcl_SetTimer(&tsdPtr->blockTime); - } else { - Tcl_SetTimer(NULL); - } + Tcl_SetTimer(&tsdPtr->blockTime); } } -- cgit v0.12 From 643e5bc24ed7dd6a21ca1a562693d0d9ce4f2651 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Nov 2013 11:00:51 +0000 Subject: Eliminate some redundant Tcl_GetErrno() calls. --- generic/tclIOGT.c | 5 +++-- win/tclWinSock.c | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index bfe6a10..825f408 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -661,12 +661,13 @@ TransformInputProc( * had some data before we report that instead of the request to * re-try. */ + int error = Tcl_GetErrno(); - if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { + if ((error == EAGAIN) && (gotBytes > 0)) { return gotBytes; } - *errorCodePtr = Tcl_GetErrno(); + *errorCodePtr = error; return -1; } else if (read == 0) { /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 00df85f..5ac8f47 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1317,8 +1317,9 @@ CreateSocket( if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - if (Tcl_GetErrno() != EWOULDBLOCK) { + DWORD error = (DWORD) WSAGetLastError(); + if (error != WSAEWOULDBLOCK) { + TclWinConvertError(error); goto looperror; } -- cgit v0.12 From 9b104b7167d18325a28a7e1c3891ce8513249e23 Mon Sep 17 00:00:00 2001 From: max Date: Mon, 18 Nov 2013 13:32:30 +0000 Subject: Revert [3c0b0bbda6]. If this really is a problem, it needs to get fixed by other means than covering behind void pointers. --- generic/tclIOSock.c | 4 ++-- generic/tclInt.h | 5 +++-- unix/tclUnixSock.c | 5 ++--- win/tclWinSock.c | 5 ++--- 4 files changed, 9 insertions(+), 10 deletions(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 7d6c462..694501f 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -139,7 +139,7 @@ int TclCreateSocketAddress( Tcl_Interp *interp, /* Interpreter for querying * the desired socket family */ - void **addrlist, /* Socket address list */ + struct addrinfo **addrlist, /* Socket address list */ const char *host, /* Host. NULL implies INADDR_ANY */ int port, /* Port number */ int willBind, /* Is this an address to bind() to or @@ -213,7 +213,7 @@ TclCreateSocketAddress( hints.ai_flags |= AI_PASSIVE; } - result = getaddrinfo(native, portstring, &hints, (struct addrinfo **) addrlist); + result = getaddrinfo(native, portstring, &hints, addrlist); if (host != NULL) { Tcl_DStringFree(&ds); diff --git a/generic/tclInt.h b/generic/tclInt.h index feea6dd..5c8dbfd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3001,8 +3001,9 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, - void **addrlist, const char *host, int port, - int willBind, const char **errorMsgPtr); + struct addrinfo **addrlist, + const char *host, int port, int willBind, + const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 7ef28d8..49a6460 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1140,7 +1140,7 @@ Tcl_OpenTcpClient( { TcpState *state; const char *errorMsg = NULL; - void *addrlist = NULL, *myaddrlist = NULL; + struct addrinfo *addrlist = NULL, *myaddrlist = NULL; char channelName[SOCK_CHAN_LENGTH]; /* @@ -1285,8 +1285,7 @@ Tcl_OpenTcpServer( ClientData acceptProcData) /* Data for the callback. */ { int status = 0, sock = -1, reuseaddr = 1, chosenport = 0; - void *addrlist = NULL; - struct addrinfo *addrPtr; /* socket address */ + struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */ TcpState *statePtr = NULL; char channelName[SOCK_CHAN_LENGTH]; const char *errorMsg = NULL; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 5ac8f47..11b4162 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1131,10 +1131,9 @@ CreateSocket( int asyncConnect = 0; /* Will be 1 if async connect is in * progress. */ unsigned short chosenport = 0; - void *addrlist = NULL, *myaddrlist = NULL; - struct addrinfo *addrPtr; + struct addrinfo *addrlist = NULL, *addrPtr; /* Socket address to connect to. */ - struct addrinfo *myaddrPtr; + struct addrinfo *myaddrlist = NULL, *myaddrPtr; /* Socket address for our side. */ const char *errorMsg = NULL; SOCKET sock = INVALID_SOCKET; -- cgit v0.12 From 18b36e37e61e3936419af460b146f5c27e2d87f1 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 015b2e6c6503106478c6dd3affa36035264c7482 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 292a07fb1ed3636070430bbcda1f350629eba5e2 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 df9709eef5f83bb6070ddb864f042cf9daff7d96 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 960a377fd1879082dbe0266533202d47cfdd5683 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 0be4102b2ac1be2e1d9d7960aa33308bdf206b02 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 c6900d988e939fafa1b1800ba27302c378d3e3c2 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 c555e477b12e11467a877024a205f39376477389 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 2254dff19ede852c343b6cc357a840917e55b112 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 91582a5e3b0cc2931ad1232c59719d602d95bfc8 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 fd3c38f894a7cce3d725b60f8d5cead803d9ff6c 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 f46d2546ab96bd78b76d02331df74ce035c356d4 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 da13f6ea8ce3f01699903c9125b1f90ad0ae2189 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 7f7ce5b4a67db42df570c86bcfbc45c4b9fa6d39 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 bcccb117121882b29a9bc45126ab15e01f76db46 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Nov 2013 12:39:27 +0000 Subject: Don't depend on TCLAPI to be defined in . If this tclOODecls.h is ever installed in an Tcl 8.x environment, it still will be usable normally. --- generic/tclOODecls.h | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 1d71359..1de3e92 100755 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -5,6 +5,14 @@ #ifndef _TCLOODECLS #define _TCLOODECLS +#ifndef TCLAPI +# ifdef BUILD_tcl +# define TCLAPI extern DLLEXPORT +# else +# define TCLAPI extern DLLIMPORT +# endif +#endif + #ifdef USE_TCL_STUBS # undef USE_TCLOO_STUBS # define USE_TCLOO_STUBS -- cgit v0.12 From ad0cd322402e0c6ea0a27927e0af3c3ae43566a1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Nov 2013 13:02:54 +0000 Subject: Take over "changes" and "doc/file.n" from trunk, it should have been merged to "novem" already. --- changes | 139 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- doc/file.n | 2 +- 2 files changed, 139 insertions(+), 2 deletions(-) diff --git a/changes b/changes index d3bbb43..659319c 100644 --- a/changes +++ b/changes @@ -8164,6 +8164,143 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) --- Released 8.6.0, December 20, 2012 --- See ChangeLog for details --- -2013-05-08 (bug fix)[3036566] Honor language packs on Vista+ to get initial locale (oehlmann) +2012-12-22 (bug fix)[3598150] DString to Tcl_Obj memleak (afredd) + +2012-12-27 (bug fix)[3598580] Tcl_ListObjReplace() refcount fix (nijtmans) + +2013-01-04 (bug fix) memleak in [format] compiler (fellows) + +2013-01-08 (bug fix)[3092089,3587096] [file normalize] on junction points + +2013-01-09 (bug fix)[3599395] status line processing (nijtmans) +2013-01-23 (bug fix)[2911139] repair async connection management (fellows) +=> http 2.8.6 + +2013-01-26 (bug fix)[3601804] Darwin segfault platformCPUID (nijtmans) + +2013-01-28 (enhancement) improve ensemble bytecode (fellows) + +2013-01-30 (enhancement) selected script code improvements (fradin) +=> tcltest 2.3.6 + +2013-01-30 (bug fix)[3599098] update to handle glibc banner changes (kupries) +=> platform 1.0.11 + +2013-01-31 (bug fix)[3598282] make install DESTDIR support (cassoff) + +2013-02-05 (bug fix)[3603434] [file normalize a:/] flaw in VFS (porter,griffin) + +2013-02-09 (bug fix)[3603695] $obj varname resolution rules (venable,fellows) + +2013-02-11 (bug fix)[3603553] zlib flushing errors (vampiera,fellows) + +2013-02-14 (bug fix)[3604576] msgcat use of Windows registry (oehlmann,nijtmans) +=> msgcat 1.5.1 + +2013-02-19 (bug fix)[2438181] report errors in trace handlers (yorick) + +2013-02-21 (bug fix)[3605447] unbreak [namespace export -clear] (porter) + +2013-02-23 (bug fix)[3599194] fallback IPv6 routines (afredd,max) + +2013-02-27 (bug fix)[3606139] stop crash in [regexp] (lane) + +2013-03-03 (bug fix)[3606258] major serial port update (english) + +2013-03-06 (bug fix)[3606683] [regexp (((((a)*)*)*)*)* {}] hangs +(grathwohl,lane,porter) + +2013-03-12 (enhancement) better build support for Debian arch (shadura) + +2013-03-19 (bug fix)[2893771] [file stat] on locked files (thoyts,nijtmans) + +2013-03-21 (bug fix)[2102614] [auto_mkindex] ensemble support (griffin) + +2013-03-27 Tcl_Zlib*() routines tolerate NULL interps (porter + +2013-04-04 (bug fix) Support URLs with query but no path (max) +=> http 2.8.7 + +2013-04-08 (bug fix)[3610026] regexp crash on color overflow (linnakangas) + +2013-04-29 (enhancement) [array set] compile improvement (fellows) + +2013-04-30 (enhancement) broaden glibc version detection (kupries) +=> platform 1.0.12 + +2013-05-06 (platform support) Cygwin64 (nijtmans) + +2013-05-15 (enhancement) Improved [list {*}...] compile (fellows) + +2013-05-16 (platform support) mingw-4.0 (nijtmans) + +2013-05-19 (platform support) FreeBSD updates (cerutti) + +2013-05-20 (bug fix)[3613567] access error temp file creation (keene) + +2013-05-20 (bug fix)[3613569] temp file open fail can crash [load] (keene) + +2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows) + +2013-05-28 (bug fix)[3036566] Use language packs (Vista+) locale (oehlmann) => msgcat 1.5.2 +2013-05-29 (bug fix)[3614102] [apply {{} {list [if 1]}}] stack woes (porter) + +2013-06-03 Restored lost performance appending to long strings (elby,porter) + +2013-06-05 (bug fix)[2835313] [while 1 {foo [continue]}] crash (fellows) + +2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans) + +2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) + +2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang) + +2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin) + +2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) + +2013-07-10 (bug fix)[86fb5e] [info frame] in compiled ensembles (porter) + +2013-07-18 (bug fix)[1c17fb] revisd syntax errorinfo that shows error (porter) + +2013-07-26 (bug fix)[6585b2] regexp {(\w).*?\1} abb (lane) + +2013-07-29 [string is space \u202f] => 1 (nijtmans) + +2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) + +2013-08-01 (bug fix)[1905562] RE recursion limit increased to support +reported usage of large expressions (porter) + +2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows)2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows) + +2013-08-03 (enhancement)[3611643] [auto_mkindex] support TclOO (fellows) + +2013-08-14 (bug fix)[a16752] Missing command delete callbacks (porter) + +2013-08-15 (bug fix)[3610404] reresolve traced forwards (porter) + +2013-08-15 Errors from execution traces become errors of the command (porter) + +2013-08-23 (bug fix)[8ff0cb9] Tcl_NR*Eval*() schedule only, as doc'd (porter) + +2013-08-29 (bug fix)[2486550] enable [interp invokehidden {} yield] (porter) + +2013-09-01 (bug fix)[b98fa55] [binary decode] fail on whitespace (reche,fellows) + +2013-09-07 (bug fix)[86ceb4] have tm path favor first provider (neumann,porter) + +2013-09-09 (bug fix)[3609693] copied object member variable confusion (fellows) +=> TclOO 1.0.1 + +2013-09-17 (bug fix)[2152292] [binary encode uuencode] corrected (fellows) + +2013-09-19 (bug fix)[3487626] segfaults in [dict] compilers (porter) + +2013-09-19 (bug fix)[31661d2] mem leak in [lreplace] (ade,porter) + +Many optmizations, improvements, and tightened stack management in bytecode. + +--- Released 8.6.1, Septemer 20, 2013 --- http://core.tcl.tk/tcl/ for details diff --git a/doc/file.n b/doc/file.n index a5a2fc8..5ff45fd 100644 --- a/doc/file.n +++ b/doc/file.n @@ -484,7 +484,7 @@ not the effective ones. .TP \fBWindows\fR\0\0\0\0 . -The \fbfile owned\fR subcommand currently always reports that the current user +The \fBfile owned\fR subcommand currently always reports that the current user is the owner of the file, without regard for what the operating system believes to be true, making an ownership test useless. This issue (#3613671) may be fixed in a future release of Tcl. -- cgit v0.12 From 8f8438c53e0a086672a12fec00764d770323caed 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 631b9c724ec78675e289d7f1dec92dc7d5165fc2 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 ff9c2d4ad9a37c50a4921bada422365ae85d5ac1 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 6c9f0c69b67589dd2c52c36bdd3fd3a7fb8e6f60 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 ec2f589b56bb7241ee7f7b60aad33ccdfa46ec98 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 bd06c04659422136285db5fbcb585c18d10b595d 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 53009920c226ade2ef2f7f12b73ee9cc0bcf766b 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 7631cbda15c13ff69b665f0b71ad20c866c00624 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 68864af6c2b0d93f8693c0f3447ffc7f8f92eb0e 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 c5df69b71626521628a0033c5e3720beaa366998 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 3cfba0cf67f0c2170e26cbff26e5dcc8bc64bf61 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 5b08f1d1ef025223ce9bc15d06dbdb88c247822a 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 05c6524f4576db17abf945a46f2a34d85d34a683 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 6af51247c19f071e11ea3f2b27724643bb7e0d70 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 13a7f30bb1ad0a3bb814f20efe88d5eb02d9e453 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 d83a8d3b91859aa6d510256f3b26c4a3d98bdd5d 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 c7d612f81758056c1d7511f1f4f8dff108ef76d7 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 1ef52b35f0c918fa1c081116f142afd4e244eaf1 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 d2ffd68c98038a0690f6a6e2f9a32b6439a7fe7e 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 ee023de8d6942ebb02809d498f6dd46f634fa98d 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 959c0b7ee6f676289f4bcb26638947b88e7d576b 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 9c336539e4efc2577c7977a99679a133bf4569c5 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 12a14105a15ca9bae71b2020fdc9d1c1b1b95dff 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 f3e8b534b38e07387ab2c0c94653917863c57411 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 974c8356eef0f2ca083bea7c55750256592e1f66 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 4cc4d69fe462a3661da5df84b1897b9959f6d5fd 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 85c73dc9ce50fd5ec5798a10173e29ab8e2c1bd1 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 40ee4723305e14d61c083785f230b614b2829361 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 db7ebfac4369ff2b956e1f5d7a8865e88d4ffc50 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 db9c1d285e21754818474eaa9be0d31b7c05e7d5 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 187d698fba3de0798b35122985b1616defa1f8e2 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 4c7d267ddb333ab1d5b6caddfdd8803def611dd0 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 3b06f70775be10c7547c05c27e55d4ef0a65ee0c 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 0dc5e35d3b0f0bda4129dd72223c109c778a4331 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 7ccc50d8b67a7e642928d04bfb66ec3ee4052fbb 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 348916814c5f0e9bac693424abe20aefe1150869 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 295782408448c9a034b86367186e93bc84f0ce7b 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 6b5eaa39012660c8f02bd6f4375089298006e987 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 96f3f9a79df5d9ce6166a00452822684e177b743 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 1749e8cdf33e8232f22acc08f9ce4301b00ba7eb 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 a8aff291ddf774fee8b1da5ccf150cc3fddae5af 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 97a9d67a6651017b5b10fe38078583043b1cb1d7 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 30c59f7cd7e2c15c29aeea8b6754f97682d07c28 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 0fa7053fd789959b2c0f1efcb486958e16e22ba0 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 d7977520d36dfb4586c6ae79c3fa3e6fc33f3b26 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 16764976baae41730e54afdca94fdf9fd18dceed 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 5f9ff26a4f64abc4d9b6c5e2f5b58e522f2b9537 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 019149dcdede4ca73450dc77d0ec916ed5757ac2 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 61fd69a37510ad47b187a6072edf47a4aebc19ce 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 292e2af7bb58a0e65d97b00604f9e59dc2ffa9ce 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 c3ba561b42a9a5ebac6660b70f30f37c923e0551 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 46e4bced044a19d781735a5c6f55a3a307dff7dc 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 f63ef2c79888c0b68ff4e0ae7815e11e2075de65 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 92f27b7095220ef6e508c9a0216e0fce97b3d2ae 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 c01192cf149de63a2a22afde7ac9adecd73f051d 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 23573493d5f31cddea12c4e9b6f8ae5a5d3f50c9 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 8bb7405765b9aed27270dfd145037e3c5884a34a 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 b9663aff14aff96677a1252092a006ae19f81a8c 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 acf1cebeab93607fc83206e77534b5fada8726ef 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 c3c6e803684022dcc788ddbfc4a59a6d0dfde102 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 aa2c40934df3fdefbb39338f7eef44e79c3c551e 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 e0791bfa1b98a28520902dbb5018ffdcb5925860 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 ab8fd1e3f28322c8d57229cd2e171fea351097af 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 61bfac2613d3cc063099ad9e6de3110491b6f5df 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 c7ed456462861ff7aaef003c61d8fc526466017d 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 6e072443704a589149fea001df51f9870b78c323 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 75c91591589708f766539aef319bfb7d80d7f0a8 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 8af83eeffaedc4ee57ade8026a6f7166b86306d6 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 9d0cf098518e48651256d556d750716978ea57df 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 b555fa4d44d0b13c0c4e61643e22f6c3479baf4e 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 15c8e0fd00cb9a49203a6de6cd05ec758daf519e 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 589975911949b9661152610ca04cf5e8e233a109 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 9df81fccd3a1cfd90a732c1116cb3bf467bbe802 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 60e360f12b1c25a8e89f5893a564ca17d3b99217 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 9ac255b85b57fd192a8255ed8d8ca73bf5306748 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 4e8c59b5b86150cbf86bfcd5c501190b4e29c138 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 7c73eea7d83b3f153f57782f4add442c09d03be0 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 e264168978eae3270ed1c67ef1152c65347db8f0 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 8079c3edb6ad6cac45822466639a9e2b9e9146e0 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 4e9008ff1b243981772ef48e1e92f2a95301b0e3 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 81e405a16c6eff768e23d1c43c292e4875b86a16 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 4c98b1f4cda633b5554ac990dfde7401bd0d67b1 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 6f611b9b973068d5630b4a227aef5fc316686036 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 a85ebc21de9b4010d0733a56197fecbb6f3d3a3b 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 347264f196f57e2f4433f33dbaa6c8e2e4a2c83d 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 009a17d3a03061610a2c281f18937e78e995855f 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 dc81fd618b33c6e9c6b8fa4b9595229ce3809f01 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 a72ae0f931f9ac8a78ef7b78f854ae68e66f9dd1 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 ee8ba589547e1b44b7851f0524f854e9b58f8dfe 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 9901c4812ae35bda160641378fab124f87238b96 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 e11501e82c5daaf3f89f915d6df764823e9edb86 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 7986522df51e69499b127ab05a24f697b5ac0849 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 4ae04fa40387165f811a88d87a1140a07bf10215 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 6e78f7a617b001eb5e35fe11cad2f469c0f48320 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 32a6fce0618ed21d85cf47b4b842ea9ee2c0c2e6 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 d8e6ba4a3b30e39fc7cde4cb5550d2157c95e194 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 67d68fe341c4c825148b48d7fd74d2136ac8fa6a 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 c3c6e18ae396cac45fbc5d94ce9e2e7b7cc2ffc3 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 bd474d3d6b7f770543d6e93ca2b6c9212c551bdf 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