diff options
| -rw-r--r-- | generic/tclBasic.c | 13 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 17 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 48 | ||||
| -rw-r--r-- | generic/tclEncoding.c | 6 |
5 files changed, 61 insertions, 27 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9691459..9968614 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -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: tclBasic.c,v 1.23 1999/12/12 02:26:40 hobbs Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.24 2000/01/21 02:25:25 hobbs Exp $ */ #include "tclInt.h" @@ -2642,6 +2642,13 @@ Tcl_EvalObjEx(interp, objPtr, flags) * * Precompiled objects, however, are immutable and therefore * they are not recompiled, even if the epoch has changed. + * + * To be pedantically correct, we should also check that the + * originating procPtr is the same as the current context procPtr + * (assuming one exists at all - none for global level). This + * code is #def'ed out because [info body] was changed to never + * return a bytecode type object, which should obviate us from + * the extra checks here. */ if (iPtr->varFramePtr != NULL) { @@ -2655,6 +2662,10 @@ Tcl_EvalObjEx(interp, objPtr, flags) if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) +#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */ + || (codePtr->procPtr != NULL && !(iPtr->varFramePtr && + iPtr->varFramePtr->procPtr == codePtr->procPtr)) +#endif || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 731bac0..c928224 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.11 1999/12/12 02:26:41 hobbs Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.12 2000/01/21 02:25:26 hobbs Exp $ */ #include "tclInt.h" @@ -257,7 +257,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) if (objc == 3) { varNamePtr = objv[2]; } - + result = Tcl_EvalObjEx(interp, objv[1], 0); if (objc == 3) { diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 4fe4f4a..4240f84 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.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: tclCmdIL.c,v 1.21 2000/01/13 20:33:10 ericm Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.22 2000/01/21 02:25:26 hobbs Exp $ */ #include "tclInt.h" @@ -563,9 +563,12 @@ InfoBodyCmd(dummy, interp, objc, objv) } /* - * we need to check if the body from this procedure had been generated - * from a precompiled body. If that is the case, then the bodyPtr's - * string representation is bogus, since sources are not available. + * We should not return a bytecompiled body. If it is precompiled, + * then the bodyPtr's string representation is bogus, since sources + * are not available. If it was just a bytecompiled body, then it + * is likely to not be of any use to the caller, as it was compiled + * for a separate procedure context [Bug: 3412], and noone else can + * reasonably use it. * In order to make sure that later manipulations of the object do not * invalidate the internal representation, we make a copy of the string * representation and return that one, instead. @@ -574,11 +577,7 @@ InfoBodyCmd(dummy, interp, objc, objv) bodyPtr = procPtr->bodyPtr; resultPtr = bodyPtr; if (bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; - - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); - } + resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); } Tcl_SetObjResult(interp, resultPtr); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5577bf1..75fa02e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.4 1999/10/29 03:04:00 hobbs Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.5 2000/01/21 02:25:26 hobbs Exp $ */ #include "tclInt.h" @@ -1579,7 +1579,7 @@ TclCompileSetCmd(interp, parsePtr, envPtr) register char *p; char *name, *elName; int nameChars, elNameChars; - register int i; + register int i, n; int isAssignment, simpleVarName, localIndex, numWords; int maxDepth = 0; int code = TCL_OK; @@ -1647,17 +1647,41 @@ TclCompileSetCmd(interp, parsePtr, envPtr) break; } } - } else if ((varTokenPtr->numComponents == 4) + } else if (((n = varTokenPtr->numComponents) > 1) && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[1].start[varTokenPtr[1].size-1] == '(') - && (varTokenPtr[4].type == TCL_TOKEN_TEXT) - && (varTokenPtr[4].size == 1) - && (varTokenPtr[4].start[0] == ')')) { - simpleVarName = 1; - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size - 1; - elName = varTokenPtr[2].start; - elNameChars = varTokenPtr[2].size; + && (varTokenPtr[n].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { + simpleVarName = 0; + + /* + * Check for parentheses inside first token + */ + for (i = 0, p = varTokenPtr[1].start; + i < varTokenPtr[1].size; i++, p++) { + if (*p == '(') { + simpleVarName = 1; + break; + } + } + if (simpleVarName) { + name = varTokenPtr[1].start; + nameChars = p - varTokenPtr[1].start; + elName = p + 1; + elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2; + + /* + * If elName contains any double quotes ("), we can't inline + * compile the element script using the replace '()' by '"' + * technique below. + */ + + for (i = 0, p = elName; i < elNameChars; i++, p++) { + if (*p == '"') { + simpleVarName = 0; + break; + } + } + } } if (simpleVarName) { diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 89453f5..c70dd0b 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -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: tclEncoding.c,v 1.4 1999/12/12 22:46:41 hobbs Exp $ + * RCS: @(#) $Id: tclEncoding.c,v 1.5 2000/01/21 02:25:26 hobbs Exp $ */ #include "tclInt.h" @@ -738,9 +738,9 @@ Tcl_CreateEncoding(typePtr) encodingPtr->nullSize = typePtr->nullSize; encodingPtr->clientData = typePtr->clientData; if (typePtr->nullSize == 1) { - encodingPtr->lengthProc = strlen; + encodingPtr->lengthProc = (LengthProc *) strlen; } else { - encodingPtr->lengthProc = unilen; + encodingPtr->lengthProc = (LengthProc *) unilen; } encodingPtr->refCount = 1; encodingPtr->hPtr = hPtr; |