From 2b2fbb042125fc15bc6a507585c6d971887ebdbe Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 29 Oct 2012 21:35:49 +0000 Subject: Added compilation of simplest practical case of [string map]. --- generic/tclAssembly.c | 10 +++--- generic/tclCmdMZ.c | 2 +- generic/tclCompCmdsSZ.c | 82 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 5 +++ generic/tclCompile.h | 19 +++++++----- generic/tclExecute.c | 52 +++++++++++++++++++++++++++++++ generic/tclInt.h | 3 ++ 7 files changed, 160 insertions(+), 13 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 5ff96fd..10df71a 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -474,6 +474,7 @@ static const TalInstDesc TalInstructionTable[] = { {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, + {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1}, {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, @@ -507,10 +508,11 @@ static const unsigned char NonThrowingByteCodes[] = { INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ INST_NOP, /* 132 */ - INST_COROUTINE_NAME, /* 142 */ - INST_NS_CURRENT, /* 143 */ - INST_INFO_LEVEL_NUM, /* 144 */ - INST_RESOLVE_COMMAND /* 146 */ + INST_STR_MAP, /* 141 */ + INST_COROUTINE_NAME, /* 143 */ + INST_NS_CURRENT, /* 144 */ + INST_INFO_LEVEL_NUM, /* 145 */ + INST_RESOLVE_COMMAND /* 147 */ }; /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 9e720ea..1f210dd 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3309,7 +3309,7 @@ TclInitStringCmd( {"is", StringIsCmd, NULL, NULL, NULL, 0}, {"last", StringLastCmd, NULL, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, - {"map", StringMapCmd, NULL, NULL, NULL, 0}, + {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, {"range", StringRangeCmd, NULL, NULL, NULL, 0}, {"repeat", StringReptCmd, NULL, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d7dd58e..b8dada5 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -557,6 +557,88 @@ TclCompileStringLenCmd( /* *---------------------------------------------------------------------- * + * TclCompileStringMapCmd -- + * + * Procedure called to compile the simplest and most common form of the + * "string map" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "string map" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringMapCmd( + 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 *mapTokenPtr, *stringTokenPtr; + Tcl_Obj *mapObj, **objv; + char *bytes; + int len; + + /* + * We only handle the case: + * + * string map {foo bar} $thing + * + * That is, a literal two-element list (doesn't need to be brace-quoted, + * but does need to be compile-time knowable) and any old argument (the + * thing to map). + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + mapTokenPtr = TokenAfter(parsePtr->tokenPtr); + stringTokenPtr = TokenAfter(mapTokenPtr); + mapObj = Tcl_NewObj(); + Tcl_IncrRefCount(mapObj); + if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { + Tcl_DecrRefCount(mapObj); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { + Tcl_DecrRefCount(mapObj); + return TCL_ERROR; + } else if (len != 2) { + Tcl_DecrRefCount(mapObj); + return TCL_ERROR; + } + + /* + * Now issue the opcodes. Note that in the case that we know that the + * first word is an empty word, we don't issue the map at all. That is the + * correct semantics for mapping. + */ + + bytes = Tcl_GetStringFromObj(objv[0], &len); + if (len == 0) { + CompileWord(envPtr, stringTokenPtr, interp, 2); + } else { + PushLiteral(envPtr, bytes, len); + bytes = Tcl_GetStringFromObj(objv[1], &len); + PushLiteral(envPtr, bytes, len); + CompileWord(envPtr, stringTokenPtr, interp, 2); + TclEmitOpcode(INST_STR_MAP, envPtr); + } + Tcl_DecrRefCount(mapObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileSubstCmd -- * * Procedure called to compile the "subst" command. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1924334..8b98746 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -435,6 +435,11 @@ InstructionDesc const tclInstructionTable[] = { * indicated by the LVT index. Part of [dict with]. * Stack: ... path keyList => ... */ + {"strmap", 1, -2, 0, {OPERAND_NONE}}, + /* Simplified version of [string map] that only applies one change + * string, and only case-sensitively. + * Stack: ... from to string => changedString */ + {"yield", 1, 0, 0, {OPERAND_NONE}}, /* Makes the current coroutine yield the value at the top of the * stack, and places the response back on top of the stack when it diff --git a/generic/tclCompile.h b/generic/tclCompile.h index fcff46c..ff2f0e3 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -681,19 +681,22 @@ typedef struct ByteCode { #define INST_DICT_RECOMBINE_STK 139 #define INST_DICT_RECOMBINE_IMM 140 +/* For [string map] and [regsub] compilation */ +#define INST_STR_MAP 141 + /* For operations to do with coroutines */ -#define INST_YIELD 141 -#define INST_COROUTINE_NAME 142 +#define INST_YIELD 142 +#define INST_COROUTINE_NAME 143 /* For compilation of basic information operations */ -#define INST_NS_CURRENT 143 -#define INST_INFO_LEVEL_NUM 144 -#define INST_INFO_LEVEL_ARGS 145 -#define INST_RESOLVE_COMMAND 146 -#define INST_TCLOO_SELF 147 +#define INST_NS_CURRENT 144 +#define INST_INFO_LEVEL_NUM 145 +#define INST_INFO_LEVEL_ARGS 146 +#define INST_RESOLVE_COMMAND 147 +#define INST_TCLOO_SELF 148 /* The last opcode */ -#define LAST_INST_OPCODE 147 +#define LAST_INST_OPCODE 148 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b42e4ab..10cbf46 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4732,6 +4732,58 @@ TEBCresume( O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); + case INST_STR_MAP: { + Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; + int length3; + Tcl_Obj *value3Ptr; + + valuePtr = OBJ_AT_TOS; /* "Main" string. */ + value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */ + value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */ + if (value3Ptr == value2Ptr || valuePtr == value2Ptr) { + objResultPtr = valuePtr; + NEXT_INST_V(1, 3, 1); + } + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + if (length == 0) { + objResultPtr = valuePtr; + NEXT_INST_V(1, 3, 1); + } + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + if (length2 > length || length2 == 0) { + objResultPtr = valuePtr; + NEXT_INST_V(1, 3, 1); + } + ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); + + objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); + p = ustring1; + end = ustring1 + length; + for (; ustring1 < end; ustring1++) { + if ((*ustring1 == *ustring2) && + (length2==1 || Tcl_UniCharNcmp(ustring1, ustring2, + (unsigned long) length2) == 0)) { + if (p != ustring1) { + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); + p = ustring1 + length2; + } else { + p += length2; + } + ustring1 = p - 1; + + Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); + } + } + if (p != ustring1) { + /* + * Put the rest of the unmapped chars onto result. + */ + + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); + } + NEXT_INST_V(1, 3, 1); + } + case INST_STR_MATCH: nocase = TclGetInt1AtPtr(pc+1); valuePtr = OBJ_AT_TOS; /* String */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 46c7a13..3aaed4c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3634,6 +3634,9 @@ MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringMapCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12