summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclBasic.c13
-rw-r--r--generic/tclCmdAH.c4
-rw-r--r--generic/tclCmdIL.c17
-rw-r--r--generic/tclCompCmds.c48
-rw-r--r--generic/tclEncoding.c6
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;