merge main working branch

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

generic/tclCompCmdsGR.c

@@ -840,6 +840,128 @@ TclCompileInfoObjectNamespaceCmd(
     return TCL_OK;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+
 /*
  *----------------------------------------------------------------------
  *

generic/tclInt.h

@@ -3535,6 +3535,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);

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