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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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