summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclBasic.c2
-rw-r--r--generic/tclCompCmdsGR.c122
-rw-r--r--generic/tclInt.h3
-rw-r--r--tests/join.test25
4 files changed, 149 insertions, 3 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 7c02706..6cb1eb4 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -223,7 +223,7 @@ static const CmdInfo builtInCmds[] = {
{"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE},
{"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE},
{"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE},
- {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"join", Tcl_JoinObjCmd, TclCompileJoinCmd, NULL, CMD_IS_SAFE},
{"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE},
{"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE},
{"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE},
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index b8a7e0f..3de773d 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -843,6 +843,128 @@ TclCompileInfoObjectNamespaceCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileJoinCmd --
+ *
+ * Procedure called to compile the "join" 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 "join" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileJoinCmd(
+ 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;
+ int separator, foreach, valueVar, loopCounter, memberVar;
+ int loopOffset, loopOffset2;
+ ForeachInfo *infoPtr;
+ JumpFixup jumpFalseFixup, separatorFixup;
+
+ /*
+ * Requires a local variable table; we're using foreach instructions
+ * internally.
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Handles: join someList ?separator?
+ *
+ * The separator, if supplied, must be a compile-time known string.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (parsePtr->numWords == 3) {
+ Tcl_Obj *separatorObj = Tcl_NewObj();
+ char *bytes;
+ int length;
+
+ if (!TclWordKnownAtCompileTime(TokenAfter(tokenPtr), separatorObj)) {
+ Tcl_DecrRefCount(separatorObj);
+ return TCL_ERROR;
+ }
+ bytes = Tcl_GetStringFromObj(separatorObj, &length);
+ if (length > 0) {
+ separator = TclRegisterNewLiteral(envPtr, bytes, length);
+ } else {
+ separator = -1;
+ }
+ Tcl_DecrRefCount(separatorObj);
+ } else if (parsePtr->numWords == 2) {
+ separator = TclRegisterNewLiteral(envPtr, " ", 1);
+ } else {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create the various variables and the auxiliary data.
+ */
+
+ valueVar = AnonymousLocal(envPtr);
+ loopCounter = AnonymousLocal(envPtr);
+ memberVar = AnonymousLocal(envPtr);
+
+ infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
+ infoPtr->numLists = 1;
+ infoPtr->firstValueTemp = valueVar;
+ infoPtr->loopCtTemp = loopCounter;
+ infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int));
+ infoPtr->varLists[0]->numVars = 1;
+ infoPtr->varLists[0]->varIndexes[0] = memberVar;
+ foreach = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
+
+ /*
+ * Issue instructions!
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ Emit14Inst( INST_STORE_SCALAR, valueVar, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ PushStringLiteral(envPtr, "");
+ TclEmitInstInt4( INST_FOREACH_START4, foreach, envPtr);
+ loopOffset = loopOffset2 = CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_FOREACH_STEP4, foreach, envPtr);
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+ if (separator >= 0) {
+ Emit14Inst( INST_LOAD_SCALAR, loopCounter, envPtr);
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &separatorFixup);
+ Emit14Inst( INST_PUSH, separator, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, memberVar, envPtr);
+ TclEmitInstInt1(INST_STR_CONCAT1, 3, envPtr);
+ loopOffset2 -= CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP1, loopOffset2, envPtr);
+ (void) TclFixupForwardJumpToHere(envPtr, &separatorFixup, 127);
+ }
+ Emit14Inst( INST_LOAD_SCALAR, memberVar, envPtr);
+ TclEmitInstInt1( INST_STR_CONCAT1, 2, envPtr);
+ loopOffset -= CurrentOffset(envPtr);
+ TclEmitInstInt1( INST_JUMP1, loopOffset, envPtr);
+ (void) TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( valueVar, envPtr);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileLappendCmd --
*
* Procedure called to compile the "lappend" command.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index f10beae..0ed2140 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3536,6 +3536,9 @@ MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileJoinCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
diff --git a/tests/join.test b/tests/join.test
index 4abe233..d3c1520 100644
--- a/tests/join.test
+++ b/tests/join.test
@@ -28,6 +28,18 @@ test join-1.3 {basic join commands} {
test join-1.4 {basic join commands} {
join {12 34 56}
} {12 34 56}
+test join-1.5 {basic join commands: compiled} {
+ apply {{} {join {a b c} xyz}}
+} axyzbxyzc
+test join-1.6 {basic join commands: compiled} {
+ apply {{} {join {a b c} {}}}
+} abc
+test join-1.7 {basic join commands: compiled} {
+ apply {{} {join {} xyz}}
+} {}
+test join-1.8 {basic join commands: compiled} {
+ apply {{} {join {12 34 56}}}
+} {12 34 56}
test join-2.1 {join errors} {
list [catch join msg] $msg $errorCode
@@ -38,12 +50,21 @@ test join-2.2 {join errors} {
test join-2.3 {join errors} {
list [catch {join "a \{ c" 111} msg] $msg $errorCode
} {1 {unmatched open brace in list} {TCL VALUE LIST BRACE}}
+test join-2.4 {join errors} {
+ list [catch {apply {{} {join "a \{ c" 111}}} msg] $msg $errorCode
+} {1 {unmatched open brace in list} {TCL VALUE LIST BRACE}}
test join-3.1 {joinString is binary ok} {
- string length [join {a b c} a\0b]
+ string length [join {a b c} a\0b]
} 9
test join-3.2 {join is binary ok} {
- string length [join "a\0b a\0b a\0b"]
+ string length [join "a\0b a\0b a\0b"]
+} 11
+test join-3.3 {joinString is binary ok} {
+ string length [apply {{} {join {a b c} a\0b}}]
+} 9
+test join-3.4 {join is binary ok} {
+ string length [apply {{} {join "a\0b a\0b a\0b"}}]
} 11
# cleanup
generated by cgit v0.12 at 2024-12-03 19:05:31 (GMT)