From edff530f8d1dba156327e87e39ef803ea58ebe8a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
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