summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c261
-rw-r--r--generic/tclCmdMZ.c155
-rw-r--r--generic/tclCompCmds.c4
-rw-r--r--generic/tclCompExpr.c4
-rw-r--r--generic/tclCompile.c113
-rw-r--r--generic/tclCompile.h5
-rw-r--r--generic/tclExecute.c12
-rw-r--r--generic/tclInt.h13
-rw-r--r--generic/tclParse.c459
9 files changed, 486 insertions, 540 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 713067c..5315494 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.76 2003/03/05 22:31:22 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.77 2003/03/13 02:48:52 dgp Exp $
*/
#include "tclInt.h"
@@ -346,7 +346,6 @@ Tcl_CreateInterp()
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
iPtr->cmdCount = 0;
- iPtr->termOffset = 0;
TclInitLiteralTable(&(iPtr->literalTable));
iPtr->compileEpoch = 0;
iPtr->compiledProcPtr = NULL;
@@ -3347,143 +3346,7 @@ Tcl_EvalTokensStandard(interp, tokenPtr, count)
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
- Tcl_Obj *resultPtr, *indexPtr, *valuePtr;
- char buffer[TCL_UTF_MAX];
-#ifdef TCL_MEM_DEBUG
-# define MAX_VAR_CHARS 5
-#else
-# define MAX_VAR_CHARS 30
-#endif
- char nameBuffer[MAX_VAR_CHARS+1];
- char *varName, *index;
- CONST char *p = NULL; /* Initialized to avoid compiler warning. */
- int length, code;
-
- /*
- * The only tricky thing about this procedure is that it attempts to
- * avoid object creation and string copying whenever possible. For
- * example, if the value is just a nested command, then use the
- * command's result object directly.
- */
-
- code = TCL_OK;
- resultPtr = NULL;
- Tcl_ResetResult(interp);
- for ( ; count > 0; count--, tokenPtr++) {
- valuePtr = NULL;
-
- /*
- * The switch statement below computes the next value to be
- * concat to the result, as either a range of text or an
- * object.
- */
-
- switch (tokenPtr->type) {
- case TCL_TOKEN_TEXT:
- p = tokenPtr->start;
- length = tokenPtr->size;
- break;
-
- case TCL_TOKEN_BS:
- length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
- buffer);
- p = buffer;
- break;
-
- case TCL_TOKEN_COMMAND:
- code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
- 0);
- if (code != TCL_OK) {
- goto done;
- }
- valuePtr = Tcl_GetObjResult(interp);
- break;
-
- case TCL_TOKEN_VARIABLE:
- if (tokenPtr->numComponents == 1) {
- indexPtr = NULL;
- index = NULL;
- } else {
- code = Tcl_EvalTokensStandard(interp, tokenPtr+2,
- tokenPtr->numComponents - 1);
- if (code != TCL_OK) {
- goto done;
- }
- indexPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(indexPtr);
- index = Tcl_GetString(indexPtr);
- }
-
- /*
- * We have to make a copy of the variable name in order
- * to have a null-terminated string. We can't make a
- * temporary modification to the script to null-terminate
- * the name, because a trace callback might potentially
- * reuse the script and be affected by the null character.
- */
-
- if (tokenPtr[1].size <= MAX_VAR_CHARS) {
- varName = nameBuffer;
- } else {
- varName = ckalloc((unsigned) (tokenPtr[1].size + 1));
- }
- strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size);
- varName[tokenPtr[1].size] = 0;
- valuePtr = Tcl_GetVar2Ex(interp, varName, index,
- TCL_LEAVE_ERR_MSG);
- if (varName != nameBuffer) {
- ckfree(varName);
- }
- if (indexPtr != NULL) {
- Tcl_DecrRefCount(indexPtr);
- }
- if (valuePtr == NULL) {
- code = TCL_ERROR;
- goto done;
- }
- count -= tokenPtr->numComponents;
- tokenPtr += tokenPtr->numComponents;
- break;
-
- default:
- panic("unexpected token type in Tcl_EvalTokensStandard");
- }
-
- /*
- * If valuePtr isn't NULL, the next piece of text comes from that
- * object; otherwise, take length bytes starting at p.
- */
-
- if (resultPtr == NULL) {
- if (valuePtr != NULL) {
- resultPtr = valuePtr;
- } else {
- resultPtr = Tcl_NewStringObj(p, length);
- }
- Tcl_IncrRefCount(resultPtr);
- } else {
- if (Tcl_IsShared(resultPtr)) {
- Tcl_DecrRefCount(resultPtr);
- resultPtr = Tcl_DuplicateObj(resultPtr);
- Tcl_IncrRefCount(resultPtr);
- }
- if (valuePtr != NULL) {
- p = Tcl_GetStringFromObj(valuePtr, &length);
- }
- Tcl_AppendToObj(resultPtr, p, length);
- }
- }
- if (resultPtr != NULL) {
- Tcl_SetObjResult(interp, resultPtr);
- } else {
- code = TCL_ERROR;
- }
-
- done:
- if (resultPtr != NULL) {
- Tcl_DecrRefCount(resultPtr);
- }
- return code;
+ return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL);
}
@@ -3579,7 +3442,7 @@ Tcl_EvalEx(interp, script, numBytes, flags)
#define NUM_STATIC_OBJS 20
Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
Tcl_Token *tokenPtr;
- int i, code, commandLength, bytesLeft, nested;
+ int i, code, commandLength, bytesLeft;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
@@ -3610,31 +3473,14 @@ Tcl_EvalEx(interp, script, numBytes, flags)
objv = staticObjArray;
p = script;
bytesLeft = numBytes;
- if (iPtr->evalFlags & TCL_BRACKET_TERM) {
- nested = 1;
- } else {
- nested = 0;
- }
iPtr->evalFlags = 0;
do {
- if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
+ if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse)
!= TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
-
- if (nested && parse.term == (script + numBytes)) {
- /*
- * A nested script can only terminate in ']'. If
- * the parsing got terminated at the end of the script,
- * there was no closing ']'. Report the syntax error.
- */
-
- code = TCL_ERROR;
- goto error;
- }
-
if (parse.numWords > 0) {
/*
* Generate an array of objects for the words of the command.
@@ -3649,8 +3495,8 @@ Tcl_EvalEx(interp, script, numBytes, flags)
for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
objectsUsed < parse.numWords;
objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
- code = Tcl_EvalTokensStandard(interp, tokenPtr+1,
- tokenPtr->numComponents);
+ code = TclSubstTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, NULL);
if (code == TCL_OK) {
objv[objectsUsed] = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objv[objectsUsed]);
@@ -3703,20 +3549,7 @@ Tcl_EvalEx(interp, script, numBytes, flags)
p = next;
Tcl_FreeParse(&parse);
gotParse = 0;
- if (nested && (*parse.term == ']')) {
- /*
- * We get here in the special case where the TCL_BRACKET_TERM
- * flag was set in the interpreter and the latest parsed command
- * was terminated by the matching close-bracket we seek.
- * Return immediately.
- */
-
- iPtr->termOffset = (p - 1) - script;
- iPtr->varFramePtr = savedVarFramePtr;
- return TCL_OK;
- }
} while (bytesLeft > 0);
- iPtr->termOffset = p - script;
iPtr->varFramePtr = savedVarFramePtr;
return TCL_OK;
@@ -3753,85 +3586,6 @@ Tcl_EvalEx(interp, script, numBytes, flags)
ckfree((char *) objv);
}
iPtr->varFramePtr = savedVarFramePtr;
-
- /*
- * All that's left to do before returning is to set iPtr->termOffset
- * to point past the end of the script we just evaluated.
- */
-
- next = parse.commandStart + parse.commandSize;
- bytesLeft -= next - p;
- p = next;
-
- if (!nested) {
- iPtr->termOffset = p - script;
- return code;
- }
-
- /*
- * When we are nested (the TCL_BRACKET_TERM flag was set in the
- * interpreter), we must find the matching close-bracket to
- * end the script we are evaluating.
- *
- * When our return code is TCL_CONTINUE or TCL_RETURN, we want
- * to correctly set iPtr->termOffset to point to that matching
- * close-bracket so our caller can move to the part of the
- * string beyond the script we were asked to evaluate.
- * So we try to parse past the rest of the commands.
- */
-
- next = NULL;
- while (bytesLeft && (*parse.term != ']')) {
- if (TCL_OK != Tcl_ParseCommand(NULL, p, bytesLeft, 1, &parse)) {
- /*
- * Syntax error. Set the termOffset to the beginning of
- * the last command parsed.
- */
-
- if (next == NULL) {
- iPtr->termOffset = (parse.commandStart - 1) - script;
- } else {
- iPtr->termOffset = (next - 1) - script;
- }
- return code;
- }
- next = parse.commandStart + parse.commandSize;
- bytesLeft -= next - p;
- p = next;
- next = parse.commandStart;
- Tcl_FreeParse(&parse);
- }
-
- if (bytesLeft) {
- /*
- * parse.term points to the close-bracket.
- */
-
- iPtr->termOffset = parse.term - script;
- } else if (parse.term == script + numBytes) {
- /*
- * There was no close-bracket. Syntax error.
- */
-
- iPtr->termOffset = parse.term - script;
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("missing close-bracket", -1));
- return TCL_ERROR;
- } else if (*parse.term != ']') {
- /*
- * There was no close-bracket. Syntax error.
- */
-
- iPtr->termOffset = (parse.term + 1) - script;
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("missing close-bracket", -1));
- return TCL_ERROR;
- } else {
- /*
- * parse.term points to the close-bracket.
- */
- iPtr->termOffset = parse.term - script;
- }
return code;
}
@@ -3933,9 +3687,6 @@ Tcl_GlobalEvalObj(interp, objPtr)
* commands will almost certainly have side effects that depend
* on those commands.
*
- * Just as in Tcl_Eval, interp->termOffset is set to the offset of the
- * last character executed in the objPtr's string.
- *
*----------------------------------------------------------------------
*/
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 2ae4819..4e70522 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.82 2003/02/27 00:54:36 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.83 2003/03/13 02:48:52 dgp Exp $
*/
#include "tclInt.h"
@@ -2490,159 +2490,6 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_SubstObj --
- *
- * This function performs the substitutions specified on the
- * given string as described in the user documentation for the
- * "subst" Tcl command. This code is heavily based on an
- * implementation by Andrew Payne. Note that if a command
- * substitution returns TCL_CONTINUE or TCL_RETURN from its
- * evaluation and is not completely well-formed, the results are
- * not defined (or at least hard to characterise.) This fault
- * will be fixed at some point, but the cost of the only sane
- * fix (well-formedness check first) is such that you need to
- * "precompile and cache" to stop everyone from being hit with
- * the consequences every time through. Note that the current
- * behaviour is not a security hole; it just restarts parsing
- * the string following the substitution in a mildly surprising
- * place, and it is a very bad idea to count on this remaining
- * the same in future...
- *
- * Results:
- * A Tcl_Obj* containing the substituted string, or NULL to
- * indicate that an error occurred.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-Tcl_SubstObj(interp, objPtr, flags)
- Tcl_Interp *interp;
- Tcl_Obj *objPtr;
- int flags;
-{
- Tcl_Obj *resultObj;
- char *p, *old;
-
- old = p = Tcl_GetString(objPtr);
- resultObj = Tcl_NewStringObj("", 0);
- while (1) {
- switch (*p) {
- case 0:
- if (p != old) {
- Tcl_AppendToObj(resultObj, old, p-old);
- }
- return resultObj;
-
- case '\\':
- if (flags & TCL_SUBST_BACKSLASHES) {
- char buf[TCL_UTF_MAX];
- int count;
-
- if (p != old) {
- Tcl_AppendToObj(resultObj, old, p-old);
- }
- Tcl_AppendToObj(resultObj, buf,
- Tcl_UtfBackslash(p, &count, buf));
- p += count;
- old = p;
- } else {
- p++;
- }
- break;
-
- case '$':
- if (flags & TCL_SUBST_VARIABLES) {
- Tcl_Parse parse;
- int code;
-
- /*
- * Code is simpler overall if we (effectively) inline
- * Tcl_ParseVar, particularly as that allows us to use
- * a non-string interface when we come to appending
- * the variable contents to the result object. There
- * are a few other optimisations that doing this
- * enables (like being able to continue the run of
- * unsubstituted characters straight through if a '$'
- * does not precede a variable name.)
- */
- if (Tcl_ParseVarName(interp, p, -1, &parse, 0) != TCL_OK) {
- goto errorResult;
- }
- if (parse.numTokens == 1) {
- /*
- * There isn't a variable name after all: the $ is
- * just a $.
- */
- p++;
- break;
- }
- if (p != old) {
- Tcl_AppendToObj(resultObj, old, p-old);
- }
- p += parse.tokenPtr->size;
- code = Tcl_EvalTokensStandard(interp, parse.tokenPtr,
- parse.numTokens);
- if (code == TCL_ERROR) {
- goto errorResult;
- }
- if (code == TCL_BREAK) {
- Tcl_ResetResult(interp);
- return resultObj;
- }
- if (code != TCL_CONTINUE) {
- Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
- }
- Tcl_ResetResult(interp);
- old = p;
- } else {
- p++;
- }
- break;
-
- case '[':
- if (flags & TCL_SUBST_COMMANDS) {
- Interp *iPtr = (Interp *) interp;
- int code;
-
- if (p != old) {
- Tcl_AppendToObj(resultObj, old, p-old);
- }
- iPtr->evalFlags = TCL_BRACKET_TERM;
- code = Tcl_EvalEx(interp, p+1, -1, 0);
- switch (code) {
- case TCL_ERROR:
- goto errorResult;
- case TCL_BREAK:
- Tcl_ResetResult(interp);
- return resultObj;
- default:
- Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
- case TCL_CONTINUE:
- Tcl_ResetResult(interp);
- old = p = (p+1 + iPtr->termOffset + 1);
- }
- } else {
- p++;
- }
- break;
- default:
- p++;
- break;
- }
- }
-
- errorResult:
- Tcl_DecrRefCount(resultObj);
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_SwitchObjCmd --
*
* This object-based procedure is invoked to process the "switch" Tcl
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 4e5f617..44f6109 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompCmds.c,v 1.41 2003/03/06 23:17:09 kennykb Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.42 2003/03/13 02:48:52 dgp Exp $
*/
#include "tclInt.h"
@@ -3140,7 +3140,7 @@ TclCompileSwitchCmd(interp, parsePtr, envPtr)
TclEmitOpcode(INST_POP, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
code = TclCompileScript(interp, bodyTokenArray[i+1].start,
- bodyTokenArray[i+1].size, /*nested*/ 0, envPtr);
+ bodyTokenArray[i+1].size, envPtr);
if (code != TCL_OK) {
ckfree((char *)argv);
ckfree((char *)bodyTokenArray);
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 1465f69..480acfe 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompExpr.c,v 1.13 2003/02/16 01:36:32 msofer Exp $
+ * RCS: @(#) $Id: tclCompExpr.c,v 1.14 2003/03/13 02:48:52 dgp Exp $
*/
#include "tclInt.h"
@@ -398,7 +398,7 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr)
case TCL_TOKEN_COMMAND:
code = TclCompileScript(interp, tokenPtr->start+1,
- tokenPtr->size-2, /*nested*/ 0, envPtr);
+ tokenPtr->size-2, envPtr);
if (code != TCL_OK) {
goto done;
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 704178b..c98348f 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.43 2003/02/19 14:33:39 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.44 2003/03/13 02:48:52 dgp Exp $
*/
#include "tclInt.h"
@@ -348,14 +348,16 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
CompileHookProc *hookProc; /* Procedure to invoke after compilation. */
ClientData clientData; /* Hook procedure private data. */
{
+#ifdef TCL_COMPILE_DEBUG
Interp *iPtr = (Interp *) interp;
+#endif /*TCL_COMPILE_DEBUG*/
CompileEnv compEnv; /* Compilation environment structure
* allocated in frame. */
LiteralTable *localTablePtr = &(compEnv.localLitTable);
register AuxData *auxDataPtr;
LiteralEntry *entryPtr;
register int i;
- int length, nested, result;
+ int length, result;
char *string;
#ifdef TCL_COMPILE_DEBUG
@@ -368,21 +370,15 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
}
#endif
- if (iPtr->evalFlags & TCL_BRACKET_TERM) {
- nested = 1;
- } else {
- nested = 0;
- }
string = Tcl_GetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string, length);
- result = TclCompileScript(interp, string, length, nested, &compEnv);
+ result = TclCompileScript(interp, string, length, &compEnv);
if (result == TCL_OK) {
/*
* Successful compilation. Add a "done" instruction at the end.
*/
- compEnv.numSrcBytes = iPtr->termOffset;
TclEmitOpcode(INST_DONE, &compEnv);
/*
@@ -786,10 +782,6 @@ TclFreeCompileEnv(envPtr)
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
- * interp->termOffset is set to the offset of the character in the
- * script just after the last one successfully processed; this will be
- * the offset of the ']' if (flags & TCL_BRACKET_TERM).
- *
* Side effects:
* Adds instructions to envPtr to evaluate the script at runtime.
*
@@ -797,7 +789,7 @@ TclFreeCompileEnv(envPtr)
*/
int
-TclCompileScript(interp, script, numBytes, nested, envPtr)
+TclCompileScript(interp, script, numBytes, envPtr)
Tcl_Interp *interp; /* Used for error and status reporting.
* Also serves as context for finding and
* compiling commands. May not be NULL. */
@@ -805,10 +797,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
int numBytes; /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
- int nested; /* Non-zero means this is a nested command:
- * close bracket ']' should be considered a
- * command terminator. If zero, close
- * bracket has no special meaning. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Interp *iPtr = (Interp *) interp;
@@ -845,55 +833,11 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
bytesLeft = numBytes;
gotParse = 0;
do {
- if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
+ if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
- if (nested) {
- /*
- * This is an unusual situation where the caller has passed us
- * a non-zero value for "nested". How unusual? Well, this
- * procedure, TclCompileScript, is internal to Tcl, so all
- * callers should be within Tcl itself. All but one of those
- * callers explicitly pass in (nested = 0). The exceptional
- * caller is TclSetByteCodeFromAny, which will pass in
- * (nested = 1) if and only if the flag TCL_BRACKET_TERM
- * is set in the evalFlags field of interp.
- *
- * It appears that the TCL_BRACKET_TERM flag is only ever set
- * by Tcl_SubstObj, and it immediately calls Tcl_EvalEx
- * which clears the flag before passing the interp along.
- * So, I don't think this procedure, TclCompileScript, is
- * **ever** called with (nested != 0).
- * (The testsuite indeed doesn't exercise this code. MS)
- *
- * This means that the branches in this procedure that are
- * only active when (nested != 0) are probably never exercised.
- * This means that any bugs in them go unnoticed, and any bug
- * fixes in them have a semi-theoretical nature.
- *
- * All that said, the spec for this procedure says it should
- * handle the (nested != 0) case, so here's an attempt to fix
- * bugs (Tcl Bug 681841) in that case. Just in case some
- * callers eventually come along and expect it to work...
- */
-
- if (parse.term == (script + numBytes)) {
- /*
- * The (nested != 0) case is meant to indicate that the
- * caller found an open bracket ([) and asked us to
- * parse and compile Tcl commands up to the matching
- * close bracket (]). We have to detect and handle
- * the case where the close bracket is missing.
- */
-
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("missing close-bracket", -1));
- code = TCL_ERROR;
- goto error;
- }
- }
if (parse.numWords > 0) {
/*
* If not the first command, pop the previous command's result
@@ -903,11 +847,8 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
if (!isFirstCmd) {
TclEmitOpcode(INST_POP, envPtr);
- if (!nested) {
- envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart)
- - startCodeOffset;
- }
+ envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart) - startCodeOffset;
}
/*
@@ -931,8 +872,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
* If tracing, print a line for each top level command compiled.
*/
- if ((tclTraceCompile >= 1)
- && !nested && (envPtr->procPtr == NULL)) {
+ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
fprintf(stdout, " Compiling: ");
TclPrintSource(stdout, parse.commandStart,
TclMin(commandLength, 55));
@@ -946,9 +886,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
envPtr->numCommands++;
currCmdIndex = (envPtr->numCommands - 1);
- if (!nested) {
- lastTopLevelCmdIndex = currCmdIndex;
- }
+ lastTopLevelCmdIndex = currCmdIndex;
startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
EnterCmdStartData(envPtr, currCmdIndex,
(parse.commandStart - envPtr->source), startCodeOffset);
@@ -1071,16 +1009,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
p = next;
Tcl_FreeParse(&parse);
gotParse = 0;
- if (nested && (*parse.term == ']')) {
- /*
- * We get here in the special case where TCL_BRACKET_TERM was
- * set in the interpreter and the latest parsed command was
- * terminated by the matching close-bracket we were looking for.
- * Stop compilation.
- */
-
- break;
- }
} while (bytesLeft > 0);
/*
@@ -1093,17 +1021,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
envPtr);
}
- if (nested) {
- /*
- * When (nested != 0) back up 1 character to have
- * iPtr->termOffset indicate the offset to the matching
- * close-bracket.
- */
-
- iPtr->termOffset = (p - 1) - script;
- } else {
- iPtr->termOffset = (p - script);
- }
+ envPtr->numSrcBytes = (p - script);
Tcl_DStringFree(&ds);
return TCL_OK;
@@ -1132,7 +1050,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
if (gotParse) {
Tcl_FreeParse(&parse);
}
- iPtr->termOffset = (p - script);
+ envPtr->numSrcBytes = (p - script);
Tcl_DStringFree(&ds);
return code;
}
@@ -1207,7 +1125,7 @@ TclCompileTokens(interp, tokenPtr, count, envPtr)
}
code = TclCompileScript(interp, tokenPtr->start+1,
- tokenPtr->size-2, /*nested*/ 0, envPtr);
+ tokenPtr->size-2, envPtr);
if (code != TCL_OK) {
goto error;
}
@@ -1396,8 +1314,7 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr)
*/
if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
- code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
- /*nested*/ 0, envPtr);
+ code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
return code;
}
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 8d5e209..bdd9ecc 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.34 2003/03/05 22:31:23 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.35 2003/03/13 02:48:53 dgp Exp $
*/
#ifndef _TCLCOMPILATION
@@ -748,8 +748,7 @@ EXTERN int TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr, int numWords,
CompileEnv *envPtr));
EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp,
- CONST char *script, int numBytes, int nested,
- CompileEnv *envPtr));
+ CONST char *script, int numBytes, CompileEnv *envPtr));
EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr));
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 18bba5d..2496126 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.94 2003/02/19 14:33:39 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.95 2003/03/13 02:48:53 dgp Exp $
*/
#include "tclInt.h"
@@ -831,7 +831,6 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr)
* and aux data items is given to the ByteCode object.
*/
- compEnv.numSrcBytes = iPtr->termOffset;
TclEmitOpcode(INST_DONE, &compEnv);
TclInitByteCodeObj(objPtr, &compEnv);
TclFreeCompileEnv(&compEnv);
@@ -1037,16 +1036,7 @@ TclCompEvalObj(interp, objPtr)
}
}
- /*
- * Set the interpreter's termOffset member to the offset of the
- * character just after the last one executed. We approximate the offset
- * of the last character executed by using the number of characters
- * compiled.
- */
-
- iPtr->termOffset = numSrcBytes;
iPtr->flags &= ~ERR_ALREADY_LOGGED;
-
return result;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3bac4d9..cd68b14 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.119 2003/03/05 22:31:24 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.120 2003/03/13 02:48:53 dgp Exp $
*/
#ifndef _TCLINT
@@ -1249,8 +1249,7 @@ typedef struct Interp {
* Normally zero, but may be set before
* calling Tcl_Eval. See below for valid
* values. */
- int termOffset; /* Offset of character just after last one
- * compiled or executed by Tcl_EvalObj. */
+ int unused1; /* No longer used (was termOffset) */
LiteralTable literalTable; /* Contains LiteralEntry's describing all
* Tcl objects holding literals of scripts
* compiled by the interpreter. Indexed by
@@ -1320,14 +1319,11 @@ typedef struct Interp {
/*
* EvalFlag bits for Interp structures:
*
- * TCL_BRACKET_TERM 1 means that the current script is terminated by
- * a close bracket rather than the end of the string.
* TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with
* a code other than TCL_OK or TCL_ERROR; 0 means
* codes other than these should be turned into errors.
*/
-#define TCL_BRACKET_TERM 1
#define TCL_ALLOW_EXCEPTIONS 4
/*
@@ -1802,7 +1798,10 @@ EXTERN void TclRememberDataKey _ANSI_ARGS_((Tcl_ThreadDataKey *mutex));
EXTERN VOID TclRememberJoinableThread _ANSI_ARGS_((Tcl_ThreadId id));
EXTERN void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex));
EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
- int result));
+ int result));
+EXTERN int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Token *tokenPtr, int count,
+ int *tokensLeftPtr));
EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
int result, Tcl_Interp *targetInterp));
EXTERN Tcl_Obj* TclpNativeToNormalized
diff --git a/generic/tclParse.c b/generic/tclParse.c
index ec8c9f0..5a7bb92 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclParse.c,v 1.25 2003/02/16 01:36:32 msofer Exp $
+ * RCS: @(#) $Id: tclParse.c,v 1.26 2003/03/13 02:48:53 dgp Exp $
*/
#include "tclInt.h"
@@ -179,7 +179,7 @@ static int CommandComplete _ANSI_ARGS_((CONST char *script,
static int ParseComment _ANSI_ARGS_((CONST char *src, int numBytes,
Tcl_Parse *parsePtr));
static int ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes,
- int mask, Tcl_Parse *parsePtr));
+ int mask, int flags, Tcl_Parse *parsePtr));
/*
*----------------------------------------------------------------------
@@ -343,7 +343,7 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr)
*/
if (ParseTokens(src, numBytes, TYPE_SPACE|terminators,
- parsePtr) != TCL_OK) {
+ TCL_SUBST_ALL, parsePtr) != TCL_OK) {
goto error;
}
src = parsePtr->term; numBytes = parsePtr->end - src;
@@ -785,9 +785,13 @@ ParseComment(src, numBytes, parsePtr)
*/
static int
-ParseTokens(src, numBytes, mask, parsePtr)
+ParseTokens(src, numBytes, mask, flags, parsePtr)
register CONST char *src; /* First character to parse. */
register int numBytes; /* Max number of bytes to scan. */
+ int flags; /* OR-ed bits indicating what substitutions
+ to perform: TCL_SUBST_COMMANDS,
+ TCL_SUBST_VARIABLES, and
+ TCL_SUBST_BACKSLASHES */
int mask; /* Specifies when to stop parsing. The
* parse stops at the first unquoted
* character whose CHAR_TYPE contains
@@ -798,6 +802,9 @@ ParseTokens(src, numBytes, mask, parsePtr)
{
char type;
int originalTokens, varToken;
+ int noSubstCmds = !(flags & TCL_SUBST_COMMANDS);
+ int noSubstVars = !(flags & TCL_SUBST_VARIABLES);
+ int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES);
Tcl_Token *tokenPtr;
Tcl_Parse nested;
@@ -831,6 +838,13 @@ ParseTokens(src, numBytes, mask, parsePtr)
tokenPtr->size = src - tokenPtr->start;
parsePtr->numTokens++;
} else if (*src == '$') {
+ if (noSubstVars) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++; numBytes--;
+ continue;
+ }
/*
* This is a variable reference. Call Tcl_ParseVarName to do
* all the dirty work of parsing the name.
@@ -844,6 +858,13 @@ ParseTokens(src, numBytes, mask, parsePtr)
src += parsePtr->tokenPtr[varToken].size;
numBytes -= parsePtr->tokenPtr[varToken].size;
} else if (*src == '[') {
+ if (noSubstCmds) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++; numBytes--;
+ continue;
+ }
/*
* Command substitution. Call Tcl_ParseCommand recursively
* (and repeatedly) to parse the nested command(s), then
@@ -896,6 +917,13 @@ ParseTokens(src, numBytes, mask, parsePtr)
tokenPtr->size = src - tokenPtr->start;
parsePtr->numTokens++;
} else if (*src == '\\') {
+ if (noSubstBS) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++; numBytes--;
+ continue;
+ }
/*
* Backslash substitution.
*/
@@ -1210,8 +1238,8 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append)
* since it could contain any number of substitutions.
*/
- if (ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, parsePtr)
- != TCL_OK) {
+ if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN,
+ TCL_SUBST_ALL, parsePtr)) {
goto error;
}
if ((parsePtr->term == (src + numBytes))
@@ -1302,7 +1330,7 @@ Tcl_ParseVar(interp, string, termPtr)
return "$";
}
- code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, parse.numTokens);
+ code = TclSubstTokens(interp, parse.tokenPtr, parse.numTokens, NULL);
if (code != TCL_OK) {
return NULL;
}
@@ -1606,7 +1634,8 @@ Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
parsePtr->errorType = TCL_PARSE_SUCCESS;
}
- if (ParseTokens(string+1, numBytes-1, TYPE_QUOTE, parsePtr) != TCL_OK) {
+ if (TCL_OK != ParseTokens(string+1, numBytes-1, TYPE_QUOTE,
+ TCL_SUBST_ALL, parsePtr)) {
goto error;
}
if (*parsePtr->term != '"') {
@@ -1631,6 +1660,420 @@ Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
/*
*----------------------------------------------------------------------
*
+ * Tcl_SubstObj --
+ *
+ * This function performs the substitutions specified on the
+ * given string as described in the user documentation for the
+ * "subst" Tcl command.
+ *
+ * Results:
+ * A Tcl_Obj* containing the substituted string, or NULL to
+ * indicate that an error occurred.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_SubstObj(interp, objPtr, flags)
+ Tcl_Interp *interp; /* Interpreter in which substitution occurs */
+ Tcl_Obj *objPtr; /* The value to be substituted */
+ int flags; /* What substitutions to do */
+{
+ int length, tokensLeft, code;
+ Tcl_Parse parse;
+ Tcl_Token *endTokenPtr;
+ Tcl_Obj *result;
+ Tcl_Obj *errMsg = NULL;
+ CONST char *p = Tcl_GetStringFromObj(objPtr, &length);
+
+ parse.tokenPtr = parse.staticTokens;
+ parse.numTokens = 0;
+ parse.tokensAvailable = NUM_STATIC_TOKENS;
+ parse.string = p;
+ parse.end = p + length;
+ parse.term = parse.end;
+ parse.interp = interp;
+ parse.incomplete = 0;
+ parse.errorType = TCL_PARSE_SUCCESS;
+
+ /*
+ * First parse the string rep of objPtr, as if it were enclosed
+ * as a "-quoted word in a normal Tcl command. Honor flags that
+ * selectively inhibit types of substitution.
+ */
+
+ if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, &parse)) {
+
+ /*
+ * There was a parse error. Save the error message for
+ * possible reporting later.
+ */
+
+ errMsg = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(errMsg);
+
+ /*
+ * We need to re-parse to get the portion of the string we can
+ * [subst] before the parse error. Sadly, all the Tcl_Token's
+ * created by the first parse attempt are gone, freed according to the
+ * public spec for the Tcl_Parse* routines. The only clue we have
+ * is parse.term, which points to either the unmatched opener, or
+ * to characters that follow a close brace or close quote.
+ *
+ * Call ParseTokens again, working on the string up to parse.term.
+ * Keep repeating until we get a good parse on a prefix.
+ */
+
+ do {
+ parse.numTokens = 0;
+ parse.tokensAvailable = NUM_STATIC_TOKENS;
+ parse.end = parse.term;
+ parse.incomplete = 0;
+ parse.errorType = TCL_PARSE_SUCCESS;
+ } while (TCL_OK != ParseTokens(p, parse.end - p, 0, flags, &parse));
+
+ /* The good parse will have to be followed by {, (, or [. */
+ switch (*parse.term) {
+ case '{':
+ /*
+ * Parse error was a missing } in a ${varname} variable
+ * substitution at the toplevel. We will subst everything
+ * up to that broken variable substitution before reporting
+ * the parse error. Substituting the leftover '$' will
+ * have no side-effects, so the current token stream is fine.
+ */
+ break;
+ case '(':
+ /*
+ * Parse error was during the parsing of the index part of
+ * an array variable substitution at the toplevel.
+ */
+ if (*(parse.term - 1) == '$') {
+ /*
+ * Special case where removing the array index left
+ * us with just a dollar sign (array variable with
+ * name the empty string as its name), instead of
+ * with a scalar variable reference.
+ *
+ * As in the previous case, existing token stream is OK.
+ */
+ } else {
+ /* The current parse includes a successful parse of a
+ * scalar variable substitution where there should have
+ * been an array variable substitution. We remove that
+ * mistaken part of the parse before moving on. A scalar
+ * variable substitution is two tokens.
+ */
+ Tcl_Token *varTokenPtr =
+ parse.tokenPtr + parse.numTokens - 2;
+
+ if (varTokenPtr->type != TCL_TOKEN_VARIABLE) {
+ Tcl_Panic("Tcl_SubstObj: programming error");
+ }
+ if (varTokenPtr[1].type != TCL_TOKEN_TEXT) {
+ Tcl_Panic("Tcl_SubstObj: programming error");
+ }
+ parse.numTokens -= 2;
+ }
+ break;
+ case '[':
+ /*
+ * Parse error occurred during parsing of a toplevel
+ * command substitution.
+ */
+
+ parse.end = p + length;
+ p = parse.term + 1;
+ length = parse.end - p;
+ if (length == 0) {
+ /*
+ * No commands, just an unmatched [.
+ * As in previous cases, existing token stream is OK.
+ */
+ } else {
+ /*
+ * We want to add the parsing of as many commands as we
+ * can within that substitution until we reach the
+ * actual parse error. We'll do additional parsing to
+ * determine what length to claim for the final
+ * TCL_TOKEN_COMMAND token.
+ */
+ Tcl_Token *tokenPtr;
+ Tcl_Parse nested;
+ CONST char *lastTerm = parse.term;
+
+ while (TCL_OK ==
+ Tcl_ParseCommand(NULL, p, length, 0, &nested)) {
+ Tcl_FreeParse(&nested);
+ p = nested.term + (nested.term < nested.end);
+ length = nested.end - p;
+ if (length == 0) {
+ /*
+ * If we run out of string, blame the missing
+ * close bracket on the last command, and do
+ * not evaluate it during substitution.
+ */
+ break;
+ }
+ lastTerm = nested.term;
+ }
+
+ if (lastTerm == parse.term) {
+ /*
+ * Parse error in first command. No commands
+ * to subst, add no more tokens.
+ */
+ break;
+ }
+
+ /*
+ * Create a command substitution token for whatever
+ * commands got parsed.
+ */
+
+ if (parse.numTokens == parse.tokensAvailable) {
+ TclExpandTokenArray(&parse);
+ }
+ tokenPtr = &parse.tokenPtr[parse.numTokens];
+ tokenPtr->start = parse.term;
+ tokenPtr->numComponents = 0;
+ tokenPtr->type = TCL_TOKEN_COMMAND;
+ tokenPtr->size = lastTerm - tokenPtr->start + 1;
+ parse.numTokens++;
+ }
+ break;
+
+ default:
+ Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]);
+ }
+ }
+
+ /* Next, substitute the parsed tokens just as in normal Tcl evaluation */
+ endTokenPtr = parse.tokenPtr + parse.numTokens;
+ tokensLeft = parse.numTokens;
+ code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
+ &tokensLeft);
+ if (code == TCL_OK) {
+ Tcl_FreeParse(&parse);
+ if (errMsg != NULL) {
+ Tcl_SetObjResult(interp, errMsg);
+ Tcl_DecrRefCount(errMsg);
+ return NULL;
+ }
+ return Tcl_GetObjResult(interp);
+ }
+ result = Tcl_NewObj();
+ while (1) {
+ switch (code) {
+ case TCL_ERROR:
+ Tcl_FreeParse(&parse);
+ Tcl_DecrRefCount(result);
+ if (errMsg != NULL) {
+ Tcl_DecrRefCount(errMsg);
+ }
+ return NULL;
+ case TCL_BREAK:
+ tokensLeft = 0; /* Halt substitution */
+ default:
+ Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp));
+ }
+
+ if (tokensLeft == 0) {
+ Tcl_FreeParse(&parse);
+ if (errMsg != NULL) {
+ if (code != TCL_BREAK) {
+ Tcl_SetObjResult(interp, errMsg);
+ Tcl_DecrRefCount(errMsg);
+ return NULL;
+ }
+ Tcl_DecrRefCount(errMsg);
+ }
+ return result;
+ }
+
+ code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
+ &tokensLeft);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSubstTokens --
+ *
+ * Accepts an array of count Tcl_Token's, and creates a result
+ * value in the interp from concatenating the results of
+ * performing Tcl substitution on each Tcl_Token. Substitution
+ * is interrupted if any non-TCL_OK completion code arises.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code. The
+ * result in interp is the substituted value, or an error message
+ * if TCL_ERROR is returned. If tokensLeftPtr is not NULL, then
+ * it points to an int where the number of tokens remaining to
+ * be processed is written.
+ *
+ * Side effects:
+ * Can be anything, depending on the types of substitution done.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr)
+ Tcl_Interp *interp; /* Interpreter in which to lookup
+ * variables, execute nested commands,
+ * and report errors. */
+ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
+ * to evaluate and concatenate. */
+ int count; /* Number of tokens to consider at tokenPtr.
+ * Must be at least 1. */
+ int *tokensLeftPtr; /* If not NULL, points to memory where an
+ * integer representing the number of tokens
+ * left to be substituted will be written */
+{
+ Tcl_Obj *result;
+ int code = TCL_OK;
+
+ /*
+ * Each pass through this loop will substitute one token, and its
+ * components, if any. The only thing tricky here is that we go to
+ * some effort to pass Tcl_Obj's through untouched, to avoid string
+ * copying and Tcl_Obj creation if possible, to aid performance and
+ * limit shimmering.
+ *
+ * Further optimization opportunities might be to check for the
+ * equivalent of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp))
+ * and omit them.
+ */
+
+ result = NULL;
+ for ( ; (count > 0) && (code == TCL_OK); count--, tokenPtr++) {
+ Tcl_Obj *appendObj = NULL;
+ CONST char *append = NULL;
+ int appendByteLength = 0;
+
+ switch (tokenPtr->type) {
+ case TCL_TOKEN_TEXT:
+ append = tokenPtr->start;
+ appendByteLength = tokenPtr->size;
+ break;
+
+ case TCL_TOKEN_BS: {
+ char utfCharBytes[TCL_UTF_MAX];
+ appendByteLength = Tcl_UtfBackslash(tokenPtr->start,
+ (int *) NULL, utfCharBytes);
+ append = utfCharBytes;
+ break;
+ }
+
+ case TCL_TOKEN_COMMAND:
+ code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
+ 0);
+ appendObj = Tcl_GetObjResult(interp);
+ break;
+
+ case TCL_TOKEN_VARIABLE: {
+ Tcl_Obj *arrayIndex = NULL;
+ Tcl_Obj *varName = NULL;
+ if (tokenPtr->numComponents > 1) {
+ /* Subst the index part of an array variable reference */
+ code = TclSubstTokens(interp, tokenPtr+2,
+ tokenPtr->numComponents - 1, NULL);
+ arrayIndex = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(arrayIndex);
+ }
+
+ if (code == TCL_OK) {
+ varName = Tcl_NewStringObj(tokenPtr[1].start,
+ tokenPtr[1].size);
+ appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex,
+ TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(varName);
+ if (appendObj == NULL) {
+ code = TCL_ERROR;
+ }
+ }
+
+ switch (code) {
+ case TCL_OK: /* Got value */
+ case TCL_ERROR: /* Already have error message */
+ case TCL_BREAK: /* Will not substitute anyway */
+ case TCL_CONTINUE: /* Will not substitute anyway */
+ break;
+ default:
+ /* All other return codes, we will subst the
+ * result from the code-throwing evaluation */
+ appendObj = Tcl_GetObjResult(interp);
+ }
+
+ if (arrayIndex != NULL) {
+ Tcl_DecrRefCount(arrayIndex);
+ }
+ count -= tokenPtr->numComponents;
+ tokenPtr += tokenPtr->numComponents;
+ break;
+ }
+
+ default:
+ Tcl_Panic("unexpected token type in TclSubstTokens: %d",
+ tokenPtr->type);
+ }
+
+ if ((code == TCL_BREAK) || (code == TCL_CONTINUE)) {
+ /* Inhibit substitution */
+ continue;
+ }
+
+ if (result == NULL) {
+ /*
+ * First pass through. If we have a Tcl_Obj, just use it.
+ * If not, create one from our string.
+ */
+
+ if (appendObj != NULL) {
+ result = appendObj;
+ } else {
+ result = Tcl_NewStringObj(append, appendByteLength);;
+ }
+ Tcl_IncrRefCount(result);
+ } else {
+ /* Subsequent passes. Append to result. */
+ if (Tcl_IsShared(result)) {
+ Tcl_DecrRefCount(result);
+ result = Tcl_DuplicateObj(result);
+ Tcl_IncrRefCount(result);
+ }
+ if (appendObj != NULL) {
+ Tcl_AppendObjToObj(result, appendObj);
+ } else {
+ Tcl_AppendToObj(result, append, appendByteLength);
+ }
+ }
+ }
+
+ if (code != TCL_ERROR) { /* Keep error message in result! */
+ if (result != NULL) {
+ Tcl_SetObjResult(interp, result);
+ } else {
+ Tcl_ResetResult(interp);
+ }
+ }
+ if (tokensLeftPtr != NULL) {
+ *tokensLeftPtr = count;
+ }
+ if (result != NULL) {
+ Tcl_DecrRefCount(result);
+ }
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* CommandComplete --
*
* This procedure is shared by TclCommandComplete and
generated by cgit v0.12 at 2024-11-16 05:54:19 (GMT)