Attachment "tip103.diff" to
ticket [570201ffff]
added by
pspjuth
2003-04-07 01:24:09.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.78
diff -u -r1.78 tclBasic.c
--- generic/tclBasic.c 5 Apr 2003 01:41:22 -0000 1.78
+++ generic/tclBasic.c 6 Apr 2003 18:03:17 -0000
@@ -98,6 +98,8 @@
(CompileProc *) NULL, 1},
{"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd,
(CompileProc *) NULL, 0},
+ {"expand", (Tcl_CmdProc *) NULL, Tcl_ExpandObjCmd,
+ TclCompileExpandCmd, 1},
{"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd,
TclCompileExprCmd, 1},
{"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd,
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.29
diff -u -r1.29 tclCmdAH.c
--- generic/tclCmdAH.c 14 Mar 2003 16:28:07 -0000 1.29
+++ generic/tclCmdAH.c 6 Apr 2003 18:03:18 -0000
@@ -30,6 +30,33 @@
static char * GetTypeFromMode _ANSI_ARGS_((int mode));
static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
char *varName, Tcl_StatBuf *statPtr));
+static void FreeExpandInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
+static int SetExpandFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+
+/*
+ * The structure below defines the "expand" Tcl object type by means of
+ * procedures that can be invoked by generic object code.
+ */
+
+Tcl_ObjType tclExpandType = {
+ "expand", /* name */
+ FreeExpandInternalRep, /* freeIntRepPro */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetExpandFromAny /* setFromAnyProc */
+};
+
+/*
+ * The following structure is the internal rep for an Expand object.
+ */
+
+typedef struct ExpandData {
+ int numWords;
+ Tcl_Obj *cmd;
+ int *expList;
+} ExpandData;
+
/*
*----------------------------------------------------------------------
@@ -667,6 +694,327 @@
Tcl_Exit(value);
/*NOTREACHED*/
return TCL_OK; /* Better not ever reach this! */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetExpandFromAny --
+ *
+ * Create an internal representation of type "Expand" for an object.
+ *
+ * Results:
+ * The return value is TCL_OK or TCL_ERROR. If an error occurs during
+ * conversion, an error message is left in the interpreter's result
+ * unless "interp" is NULL.
+ *
+ * Side effects:
+ * Any old internal representation for objPtr is freed and the
+ * internal representation is set to "Expand".
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetExpandFromAny(interp, objPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr; /* The object to convert. */
+{
+ ExpandData *expandPtr;
+ char *script, *cmd;
+ const char *next;
+ int length, i;
+ Tcl_Parse parse, parse2;
+ Tcl_Token *tokenPtr, *subTokenPtr;
+
+ if (objPtr->typePtr == &tclExpandType) {
+ return TCL_OK;
+ }
+
+ /*
+ * Parse the command into words.
+ */
+
+ script = Tcl_GetStringFromObj(objPtr, &length);
+ if (Tcl_ParseCommand(interp, script, length, 0, &parse) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check if the rest contains any command.
+ */
+
+ next = parse.commandStart + parse.commandSize;
+ if (*next != 0) {
+ if (Tcl_ParseCommand(interp, next, -1, 0, &parse2) != TCL_OK) {
+ Tcl_FreeParse(&parse);
+ return TCL_ERROR;
+ }
+ if (parse2.numWords > 0) {
+ Tcl_FreeParse(&parse);
+ Tcl_FreeParse(&parse2);
+ if (interp != NULL) {
+ Tcl_SetResult(interp,
+ "only one statement is allowed in expand",
+ TCL_STATIC);
+ }
+ return TCL_ERROR;
+ }
+ Tcl_FreeParse(&parse2);
+ }
+
+ /*
+ * Look for illegal usages of `
+ */
+
+ for (i = 0, tokenPtr = parse.tokenPtr; i < parse.numWords;
+ i++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ if (tokenPtr->start[0] == '`') {
+ if ((tokenPtr->type == TCL_TOKEN_WORD)
+ && (tokenPtr->numComponents >= 2)) {
+ /*
+ * The first subToken should be a single char TCL_TOKEN_TEXT
+ */
+ subTokenPtr = tokenPtr + 1;
+ if ((subTokenPtr->type == TCL_TOKEN_TEXT) &&
+ (subTokenPtr->size == 1)) {
+ /*
+ * The next subToken should be a TCL_TOKEN_COMMAND or
+ * TCL_TOKEN_VARIABLE, and its subTokens should be the
+ * rest of the word's tokens. */
+
+ subTokenPtr = tokenPtr + 2;
+ if (((subTokenPtr->type == TCL_TOKEN_COMMAND) ||
+ (subTokenPtr->type == TCL_TOKEN_VARIABLE)) &&
+ (subTokenPtr->numComponents + 2 ==
+ tokenPtr->numComponents)) {
+ continue;
+ }
+ }
+ }
+
+ /*
+ * It's illegal
+ */
+
+ if (interp != NULL) {
+ Tcl_SetResult(interp,
+ "` must be followed by a single variable or command",
+ TCL_STATIC);
+ }
+ Tcl_FreeParse(&parse);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Turn into an Expand object
+ */
+
+ if ((objPtr->typePtr != NULL) &&
+ (objPtr->typePtr->freeIntRepProc != NULL)) {
+ (*objPtr->typePtr->freeIntRepProc)(objPtr);
+ }
+ expandPtr = (ExpandData *) ckalloc(sizeof(ExpandData));
+ objPtr->typePtr = &tclExpandType;
+ objPtr->internalRep.otherValuePtr = (VOID *) expandPtr;
+
+ expandPtr->numWords = parse.numWords;
+
+ if (parse.numWords < 1) {
+ Tcl_FreeParse(&parse);
+ return TCL_OK;
+ }
+
+ /*
+ * Build a command string consisting of 'list' followed by
+ * the command's words with any "`" removed.
+ * This command string when evaluated will return a list of the
+ * command's words after all substitutions.
+ */
+
+ cmd = ckalloc(6 + length);
+ expandPtr->expList = (int *) ckalloc(sizeof(int) * expandPtr->numWords);
+ strcpy(cmd , "list");
+
+ for (i = 0, tokenPtr = parse.tokenPtr; i < parse.numWords;
+ i++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ strcat(cmd, " ");
+ if ((tokenPtr->start[0] == '`') && (tokenPtr->type == TCL_TOKEN_WORD)
+ && (tokenPtr->numComponents >= 2)) {
+ /*
+ * The first subToken should be a single char TCL_TOKEN_TEXT
+ */
+ subTokenPtr = tokenPtr + 1;
+ if ((subTokenPtr->type == TCL_TOKEN_TEXT) &&
+ (subTokenPtr->size == 1)) {
+ /*
+ * The next subToken should be a TCL_TOKEN_COMMAND or
+ * TCL_TOKEN_VARIABLE, and its subTokens should be the
+ * rest of the word's tokens. */
+
+ subTokenPtr = tokenPtr + 2;
+ if (((subTokenPtr->type == TCL_TOKEN_COMMAND) ||
+ (subTokenPtr->type == TCL_TOKEN_VARIABLE)) &&
+ (subTokenPtr->numComponents + 2 ==
+ tokenPtr->numComponents)) {
+
+ strncat(cmd, tokenPtr->start + 1, tokenPtr->size - 1);
+ expandPtr->expList[i] = 1;
+ continue;
+ }
+ }
+ }
+
+ /*
+ * The requirements for expansion where not fulfilled so
+ * we keep it as is.
+ */
+
+ strncat(cmd, tokenPtr->start, tokenPtr->size);
+ expandPtr->expList[i] = 0;
+ }
+ Tcl_FreeParse(&parse);
+
+ /*
+ * Put the command string in an object so it can be
+ * byte compiled when evaluated.
+ */
+
+ expandPtr->cmd = Tcl_NewStringObj(cmd, -1);
+ Tcl_IncrRefCount(expandPtr->cmd);
+ ckfree(cmd);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeExpandInternalRep --
+ *
+ * Deallocate the storage associated with a Expand data object's
+ * internal representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeExpandInternalRep(objPtr)
+ Tcl_Obj *objPtr; /* Object with internal rep to free. */
+{
+ ExpandData *expandPtr = (ExpandData *) objPtr->internalRep.otherValuePtr;
+ if (expandPtr->numWords > 0) {
+ Tcl_DecrRefCount(expandPtr->cmd);
+ ckfree((char *) expandPtr->expList);
+ }
+ ckfree((char *) expandPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ExpandObjCmd --
+ *
+ * This procedure is invoked to process the "expand" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_ExpandObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int i, code = TCL_OK;
+ ExpandData *expandPtr;
+ Tcl_Obj *expCmd, *res;
+ Tcl_Obj **resObjv;
+ int resObjc;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command");
+ return TCL_ERROR;
+ }
+
+ if (SetExpandFromAny(interp, objv[1]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ expandPtr = (ExpandData *) objv[1]->internalRep.otherValuePtr;
+
+ if (expandPtr->numWords < 1) {
+ return TCL_OK;
+ }
+
+ /*
+ * Eval the converted command string.
+ */
+
+ code = Tcl_EvalObjEx(interp, expandPtr->cmd, 0);
+ if (code != TCL_OK) {
+ char msg[32 + TCL_INTEGER_SPACE];
+
+ sprintf(msg, "\n (\"expand\" body line %d)", interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ return code;
+ }
+
+ /*
+ * Get the resulting list and perform expansion.
+ */
+
+ res = Tcl_GetObjResult(interp);
+ code = Tcl_ListObjGetElements(interp, res, &resObjc, &resObjv);
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (expandPtr->numWords != resObjc) {
+ Tcl_SetResult(interp, "word boundaries changed during expand parsing",
+ TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ expCmd = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(expCmd);
+
+ for (i = 0; i < expandPtr->numWords && i < resObjc; i++) {
+ if (expandPtr->expList[i]) {
+ /* Expanded argument, append its elements */
+ if (Tcl_ListObjAppendList(interp, expCmd, resObjv[i]) != TCL_OK) {
+ Tcl_DecrRefCount(expCmd);
+ return TCL_ERROR;
+ }
+ } else {
+ /* Not expanded, just append to command */
+ Tcl_ListObjAppendElement(interp, expCmd, resObjv[i]);
+ }
+ }
+
+ /*
+ * Execute the expanded command.
+ */
+
+ code = Tcl_EvalObjEx(interp, expCmd, TCL_EVAL_DIRECT);
+ Tcl_DecrRefCount(expCmd);
+ return code;
}
/*
Index: generic/tclCompCmds.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompCmds.c,v
retrieving revision 1.45
diff -u -r1.45 tclCompCmds.c
--- generic/tclCompCmds.c 3 Apr 2003 16:46:43 -0000 1.45
+++ generic/tclCompCmds.c 6 Apr 2003 18:03:19 -0000
@@ -429,6 +429,277 @@
/*
*----------------------------------------------------------------------
*
+ * TclCompileExpandCmd --
+ *
+ * Procedure called to compile the "expand" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * compilation was successful. If an error occurs then the
+ * interpreter's result contains a standard error message and TCL_ERROR
+ * is returned. If the command is too complex for TclCompileExpandCmd,
+ * TCL_OUT_LINE_COMPILE is returned indicating that the catch command
+ * should be compiled "out of line" by emitting code to invoke its
+ * command procedure at runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "expand" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileExpandCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *argTokenPtr, *textTokenPtr, *tokenPtr, *subTokenPtr;
+ Tcl_Parse parse, parse2;
+ const char *script, *next;
+ char *cmd, *expList;
+ int length, i, wordIdx, objIndex, code, numWords;
+
+ if (parsePtr->numWords != 2) {
+ Tcl_SetResult(interp, "wrong # args: should be \"expand command\"",
+ TCL_STATIC);
+ return TCL_ERROR;
+ }
+ argTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+
+ if (argTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+ textTokenPtr = argTokenPtr + 1;
+
+ /*
+ * Parse the command into words.
+ */
+
+ script = textTokenPtr->start;
+ length = textTokenPtr->size;
+ if (Tcl_ParseCommand(interp, script, length, 0, &parse) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check if the rest contains any command.
+ */
+
+ next = parse.commandStart + parse.commandSize;
+ if (*next != 0) {
+ if (Tcl_ParseCommand(interp, next, length - (next - script), 0,
+ &parse2) != TCL_OK) {
+ Tcl_FreeParse(&parse);
+ return TCL_ERROR;
+ }
+ if (parse2.numWords > 0) {
+ Tcl_FreeParse(&parse);
+ Tcl_FreeParse(&parse2);
+ Tcl_SetResult(interp,
+ "only one statement is allowed in expand",
+ TCL_STATIC);
+ return TCL_ERROR;
+ }
+ Tcl_FreeParse(&parse2);
+ }
+
+ if (parse.numWords < 1) {
+ /* Empty command, just return empty result */
+ Tcl_FreeParse(&parse);
+ objIndex = TclRegisterLiteral(envPtr, "", 0, 0);
+ TclEmitPush(objIndex, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * Look for illegal usages of `
+ */
+
+ for (i = 0, tokenPtr = parse.tokenPtr; i < parse.numWords;
+ i++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ if (tokenPtr->start[0] == '`') {
+ if ((tokenPtr->type == TCL_TOKEN_WORD)
+ && (tokenPtr->numComponents >= 2)) {
+ /*
+ * The first subToken should be a single char TCL_TOKEN_TEXT
+ */
+ subTokenPtr = tokenPtr + 1;
+ if ((subTokenPtr->type == TCL_TOKEN_TEXT) &&
+ (subTokenPtr->size == 1)) {
+ /*
+ * The next subToken should be a TCL_TOKEN_COMMAND or
+ * TCL_TOKEN_VARIABLE, and its subTokens should be the
+ * rest of the word's tokens. */
+
+ subTokenPtr = tokenPtr + 2;
+ if (((subTokenPtr->type == TCL_TOKEN_COMMAND) ||
+ (subTokenPtr->type == TCL_TOKEN_VARIABLE)) &&
+ (subTokenPtr->numComponents + 2 ==
+ tokenPtr->numComponents)) {
+ continue;
+ }
+ }
+ }
+
+ /*
+ * It's illegal
+ */
+
+ if (interp != NULL) {
+ Tcl_SetResult(interp,
+ "` must be followed by a single variable or command",
+ TCL_STATIC);
+ }
+ Tcl_FreeParse(&parse);
+ return TCL_ERROR;
+ }
+ }
+
+ numWords = parse.numWords;
+
+ /*
+ * Build a command string consisting of
+ * the command's words with any "`" removed.
+ */
+
+ cmd = ckalloc(length + 1);
+ cmd[0] = 0;
+ expList = ckalloc(parse.numWords * 2 + 1);
+ expList[0] = 0;
+
+ for (i = 0, tokenPtr = parse.tokenPtr; i < parse.numWords;
+ i++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ if (i != 0) {
+ strcat(cmd, " ");
+ strcat(expList, " ");
+ }
+ if ((tokenPtr->start[0] == '`') && (tokenPtr->type == TCL_TOKEN_WORD)
+ && (tokenPtr->numComponents >= 2)) {
+ /*
+ * The first subToken should be a single char TCL_TOKEN_TEXT
+ */
+ subTokenPtr = tokenPtr + 1;
+ if ((subTokenPtr->type == TCL_TOKEN_TEXT) &&
+ (subTokenPtr->size == 1)) {
+ /*
+ * The next subToken should be a TCL_TOKEN_COMMAND or
+ * TCL_TOKEN_VARIABLE, and its subTokens should be the
+ * rest of the word's tokens. */
+
+ subTokenPtr = tokenPtr + 2;
+ if (((subTokenPtr->type == TCL_TOKEN_COMMAND) ||
+ (subTokenPtr->type == TCL_TOKEN_VARIABLE)) &&
+ (subTokenPtr->numComponents + 2 ==
+ tokenPtr->numComponents)) {
+
+ strncat(cmd, tokenPtr->start + 1, tokenPtr->size - 1);
+ strcat(expList, "1");
+ continue;
+ }
+ }
+ }
+
+ /*
+ * The requirements for expansion where not fulfilled so
+ * we keep it as is.
+ */
+
+ strncat(cmd, tokenPtr->start, tokenPtr->size);
+ strcat(expList, "0");
+ }
+ Tcl_FreeParse(&parse);
+
+ /* Compile the command */
+
+ if (Tcl_ParseCommand(interp, cmd, -1, 0, &parse) != TCL_OK) {
+ char msg[32 + TCL_INTEGER_SPACE];
+
+ sprintf(msg, "\n (\"expand\" body line %d)", interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ ckfree(cmd);
+ ckfree(expList);
+ return TCL_ERROR;
+ }
+ if (parse.numWords < 1) {
+ panic("compile expand: null command reached second parse");
+ }
+
+ /*
+ * Word boundaries should not have been affected by removing
+ * the `s.
+ */
+
+ if (parse.numWords != numWords) {
+ Tcl_FreeParse(&parse);
+ ckfree(cmd);
+ ckfree(expList);
+ Tcl_SetResult(interp, "word boundaries changed during expand parsing",
+ TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Each iteration of the following loop compiles one word
+ * from the command.
+ */
+
+ for (wordIdx = 0, tokenPtr = parse.tokenPtr;
+ wordIdx < parse.numWords;
+ wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ objIndex = TclRegisterLiteral(envPtr,
+ (char *) tokenPtr[1].start, tokenPtr[1].size,
+ /*onHeap*/ 0);
+ TclEmitPush(objIndex, envPtr);
+ } else {
+ /*
+ * The word is not a simple string of characters.
+ */
+
+ code = TclCompileTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto error;
+ }
+ }
+ }
+
+ /*
+ * Push the expand flags.
+ */
+
+ objIndex = TclRegisterLiteral(envPtr, expList, -1, 1);
+ TclEmitPush(objIndex, envPtr);
+ expList = NULL;
+
+ /*
+ * Emit an expand instruction for the command.
+ */
+
+ if (wordIdx > 0) {
+ if (wordIdx <= 255) {
+ TclEmitInstInt1(INST_EXPAND_STK1, wordIdx, envPtr);
+ } else {
+ TclEmitInstInt4(INST_EXPAND_STK4, wordIdx, envPtr);
+ }
+ }
+
+ code = TCL_OK;
+ error:
+ Tcl_FreeParse(&parse);
+ ckfree(cmd);
+ if (expList != NULL) ckfree(expList);
+
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileExprCmd --
*
* Procedure called to compile the "expr" command.
Index: generic/tclCompile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.c,v
retrieving revision 1.46
diff -u -r1.46 tclCompile.c
--- generic/tclCompile.c 19 Mar 2003 22:24:14 -0000 1.46
+++ generic/tclCompile.c 6 Apr 2003 18:03:19 -0000
@@ -271,6 +271,10 @@
*/
{"return", 1, -1, 0, {OPERAND_NONE}},
/* return TCL_RETURN code. */
+ {"expandStk1", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ /* Expand command and invoke it. */
+ {"expandStk4", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* Expand command and invoke it. */
{0}
};
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.36
diff -u -r1.36 tclCompile.h
--- generic/tclCompile.h 19 Mar 2003 16:51:42 -0000 1.36
+++ generic/tclCompile.h 6 Apr 2003 18:03:19 -0000
@@ -524,8 +524,15 @@
#define INST_RETURN 98
+/*
+ * TIP #103 - 'expand' command.
+ */
+
+#define INST_EXPAND_STK1 99
+#define INST_EXPAND_STK4 100
+
/* The last opcode */
-#define LAST_INST_OPCODE 98
+#define LAST_INST_OPCODE 100
/*
* Table describing the Tcl bytecode instructions: their name (for
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.97
diff -u -r1.97 tclExecute.c
--- generic/tclExecute.c 1 Apr 2003 07:18:37 -0000 1.97
+++ generic/tclExecute.c 6 Apr 2003 18:03:20 -0000
@@ -1321,7 +1321,110 @@
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
}
+
+ case INST_EXPAND_STK4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ goto doExpand;
+
+ case INST_EXPAND_STK1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+ doExpand:
+ {
+ Tcl_Obj *expList = stackPtr[stackTop];
+ int expObjc;
+ Tcl_Obj **expObjv;
+ int doExp;
+ Tcl_Obj *expCmd;
+ int objc = opnd;
+ Tcl_Obj **objv = &(stackPtr[stackTop - objc]);
+
+ /* Get the list of flags that says what shall be expanded. */
+
+ if (Tcl_ListObjGetElements(interp, expList, &expObjc, &expObjv)
+ != TCL_OK) {
+ panic("Expand byte code: Found nonvalid expand list");
+ }
+
+ /* Build a command with arguments expanded. */
+
+ expCmd = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(expCmd);
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetIntFromObj(interp, expObjv[i], &doExp) != TCL_OK) {
+ panic("Expand byte code: Found nonvalid expand flag '%s' at %d in list '%s'",
+ Tcl_GetString(expObjv[i]), i,
+ Tcl_GetString(expList));
+ }
+ if (doExp) {
+ /* Expanded argument, append its elements */
+ result = Tcl_ListObjAppendList(interp, expCmd, objv[i]);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(expCmd);
+ goto checkForCatch;
+ }
+ } else {
+ /* Not expanded, just append to command */
+ Tcl_ListObjAppendElement(interp, expCmd, objv[i]);
+ }
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ int eObjc;
+ Tcl_Obj **eObjv;
+ Tcl_ListObjGetElements(interp, expCmd, &eObjc, &eObjv);
+ if (traceInstructions) {
+ if (eObjc == 0) {
+ strcpy(cmdNameBuf, "");
+ } else {
+ strncpy(cmdNameBuf, TclGetString(eObjv[0]), 20);
+ }
+ TRACE(("%u => call ", eObjc));
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ",
+ iPtr->numLevels,
+ (unsigned int)(pc - codePtr->codeStart));
+ }
+ for (i = 0; i < eObjc && i < 10; i++) {
+ TclPrintObject(stdout, eObjv[i], 15);
+ fprintf(stdout, " ");
+ }
+ if (i < eObjc) {
+ fprintf(stdout, "...");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+
+ /* Execute the expanded command. */
+
+ Tcl_ResetResult(interp);
+ DECACHE_STACK_INFO();
+ result = Tcl_EvalObjEx(interp, expCmd, TCL_EVAL_DIRECT);
+ CACHE_STACK_INFO();
+ Tcl_DecrRefCount(expCmd);
+
+ if (result == TCL_OK) {
+ /*
+ * Push the call's object result and continue execution
+ * with the next instruction.
+ */
+
+ TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=",
+ objc, cmdNameBuf), Tcl_GetObjResult(interp));
+
+ objResultPtr = Tcl_GetObjResult(interp);
+ NEXT_INST_V(pcAdjustment, opnd + 1, 1);
+ } else {
+ cleanup = opnd + 1;
+ goto processExceptionReturn;
+ }
+ }
+
case INST_INVOKE_STK4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.123
diff -u -r1.123 tclInt.h
--- generic/tclInt.h 5 Apr 2003 01:41:23 -0000 1.123
+++ generic/tclInt.h 6 Apr 2003 18:03:21 -0000
@@ -1558,6 +1558,7 @@
extern Tcl_ObjType tclDictType;
extern Tcl_ObjType tclProcBodyType;
extern Tcl_ObjType tclStringType;
+extern Tcl_ObjType tclExpandType;
extern Tcl_ObjType tclArraySearchType;
extern Tcl_ObjType tclIndexType;
extern Tcl_ObjType tclNsNameType;
@@ -1832,6 +1833,8 @@
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_ExpandObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -1983,6 +1986,8 @@
EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileExpandCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
Index: generic/tclObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclObj.c,v
retrieving revision 1.43
diff -u -r1.43 tclObj.c
--- generic/tclObj.c 5 Apr 2003 01:41:23 -0000 1.43
+++ generic/tclObj.c 6 Apr 2003 18:03:21 -0000
@@ -237,6 +237,7 @@
Tcl_RegisterObjType(&tclWideIntType);
#endif
Tcl_RegisterObjType(&tclStringType);
+ Tcl_RegisterObjType(&tclExpandType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
Index: tests/cmdAH.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/cmdAH.test,v
retrieving revision 1.30
diff -u -r1.30 cmdAH.test
--- tests/cmdAH.test 9 Jan 2003 10:38:32 -0000 1.30
+++ tests/cmdAH.test 6 Apr 2003 18:03:22 -0000
@@ -1678,6 +1678,284 @@
interp delete safeInterp
interp delete simpleInterp
+# Some lists for expand tests to work with
+set l1 [list a {b b} c d]
+set l2 [list e f {g g} h]
+proc l3 {} {
+ list i j k {l l}
+}
+
+# A special procedure to control if expand is byte compiled
+proc eproc {name arg body} {
+ if {$::noComp} {
+ regsub -all "expand" $body {[list expand]} body
+ }
+ proc $name $arg $body
+}
+
+# Do all tests once byte compiled and once "normal"
+for {set noComp 0} {$noComp <= 1} {incr noComp} {
+
+test cmdAH-32.1.$noComp {expand command: errors} {
+ -body {
+ eproc expTmp {} { expand }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {wrong # args: should be "expand command"}
+ -returnCodes 1
+}
+
+test cmdAH-32.2.$noComp {expand command: errors} {
+ -body {
+ eproc expTmp {} { expand apa bepa }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {wrong # args: should be "expand command"}
+ -returnCodes 1
+}
+
+test cmdAH-32.3.$noComp {expand command: errors} {
+ -body {
+ eproc expTmp {} { expand {list 1 ; list 2} }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {only one statement is allowed in expand}
+ -returnCodes 1
+}
+
+test cmdAH-32.4.$noComp {expand command: Accept whitespace and comments} {
+ -body {
+ eproc expTmp {} {
+ expand { # A comment
+
+ # Another comment
+ list 1 2\
+ 3 `$::l1
+
+ # Comment again
+ }
+ }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {1 2 3 a {b b} c d}
+}
+
+test cmdAH-32.5.$noComp {expand command: no expansion} {
+ -body {
+ eproc expTmp {} { expand {list $::l1 $::l2 [l3]} }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {{a {b b} c d} {e f {g g} h} {i j k {l l}}}
+}
+
+test cmdAH-32.6.$noComp {expand command: expansion} {
+ -body {
+ eproc expTmp {} { expand {list `$::l1 $::l2 `[l3]} }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {a {b b} c d {e f {g g} h} i j k {l l}}
+}
+
+test cmdAH-32.7.$noComp {expand command: really long cmd} {
+ -body {
+ set cmd [list list]
+ for {set t 0} {$t < 500} {incr t} {
+ lappend cmd {`$::l1}
+ }
+ eproc expTmp {} " expand {[join $cmd]} "
+ llength [expTmp]
+ }
+ -cleanup {rename expTmp {}}
+ -result {2000}
+}
+
+test cmdAH-32.8.$noComp {expand command: error detection} {
+ -body {
+ eproc expTmp {} {
+ set l "a {a b}x y"
+ expand {list $::l1 `$l}
+ }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {list element in braces followed by "x" instead of space}
+ -returnCodes 1
+}
+
+test cmdAH-32.9.$noComp {expand command: ignore impure usage} {
+ -body {
+ eproc expTmp {} { expand {list `$::l1$::l2} }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {{`a {b b} c de f {g g} h}} -result FIXA
+ -result {` must be followed by a single variable or command}
+ -returnCodes 1
+}
+
+test cmdAH-32.10.$noComp {expand command: ignore impure usage} {
+ -body {
+ eproc expTmp {} { expand {list `[l3]$::l1} }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {{`i j k {l l}a {b b} c d}}
+ -result {` must be followed by a single variable or command}
+ -returnCodes 1
+}
+
+test cmdAH-32.11.$noComp {expand command: ignore impure usage} {
+ -body {
+ eproc expTmp {} { expand {list `hej$::l1} }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {{`heja {b b} c d}}
+ -result {` must be followed by a single variable or command}
+ -returnCodes 1
+}
+
+test cmdAH-32.12.$noComp {expand command: Not all ` should trigger} {
+ -body {
+ eproc expTmp {} {
+ expand {list `$::l1 \`$::l2 "`$::l1" {` i j k}}
+ }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {a {b b} c d {`e f {g g} h} {`a {b b} c d} {` i j k}}
+}
+
+test cmdAH-32.13.$noComp {expand command: extra eval} {
+ -body { expand "list `\$l1 \$l2 `\[l3\]" }
+ -result {a {b b} c d {e f {g g} h} i j k {l l}}
+}
+
+test cmdAH-32.14.$noComp {expand command: expansion of command word} {
+ -body {
+ eproc expTmp {} {
+ set cmd [list string range jultomte]
+ expand {`$cmd 2 6}
+ }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {ltomt}
+}
+
+test cmdAH-32.15.$noComp {expand command: expansion into nothing} {
+ -body {
+ eproc expTmp {} {
+ set cmd {}
+ set bar {}
+ expand {`$cmd `$bar}
+ }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {}
+}
+
+test cmdAH-32.16.$noComp {expand command: odd case with word boundaries} {
+ -body {
+ eproc expTmp {} { expand {list `$::l1 `"hej hopp" `$::l2} }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {a {b b} c d {`"hej} hopp\" e f {g g} h}
+ -result {` must be followed by a single variable or command}
+ -returnCodes 1
+} ;#" Extra quote to balance syntax coloring
+
+test cmdAH-32.17.$noComp {expand command: odd case with word boundaries} {
+ -body {
+ eproc expTmp {} { expand {list `$::l1 `{hej hopp} `$::l2} }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {a {b b} c d \`\{hej hopp\} e f {g g} h}
+ -result {` must be followed by a single variable or command}
+ -returnCodes 1
+}
+
+test cmdAH-32.18.$noComp {expand command: odd case with word boundaries} {
+ -body {
+ eproc expTmp {} { expand {list `$::l1 `"hej hopp `$::l2} }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {a {b b} c d {`"hej} hopp e f {g g} h}
+ -result {` must be followed by a single variable or command}
+ -returnCodes 1
+}
+
+test cmdAH-32.19.$noComp {expand command: handle return codes} {
+ -body {
+ eproc expTmp {} {
+ set res {}
+ for {set t 0} {$t < 10} {incr t} {
+ expand { break }
+ }
+ lappend res $t
+
+ for {set t 0} {$t < 10} {incr t} {
+ expand { continue }
+ set t 20
+ }
+ lappend res $t
+
+ lappend res [catch { expand { error Hejsan } } err]
+ lappend res $err
+ }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {0 10 1 Hejsan}
+}
+
+test cmdAH-32.20.$noComp {expand command: hash command} {
+ -body {
+ eproc expTmp {} {
+ set cmd "#"
+ expand { $cmd apa bepa }
+ }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {invalid command name "#"}
+ -returnCodes 1
+}
+
+test cmdAH-32.21.$noComp {expand command: complex words} {
+ -body {
+ eproc expTmp {} {
+ set a(x) [list a {b c} d e]
+ set b x
+ set c [list {f\ g h\ i j k} x y]
+ set d {0\ 1 2 3}
+ expand { lappend d `$a($b) `[lindex $c 0] }
+ }
+ expTmp
+ }
+ -cleanup {rename expTmp {}}
+ -result {{0 1} 2 3 a {b c} d e {f g} {h i} j k}
+}
+
+} ;# End of noComp loop
+
+# Clean up after expand tests
+unset noComp
+unset l1
+unset l2
+rename l3 {}
+
+
# cleanup
catch {testsetplatform $platform}
catch {unset platform}
