summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c40
-rw-r--r--generic/tclCmdAH.c14
-rw-r--r--generic/tclCmdMZ.c4
-rw-r--r--generic/tclCompile.c5
-rw-r--r--generic/tclExecute.c87
-rw-r--r--generic/tclMain.c6
-rw-r--r--generic/tclNamesp.c13
-rw-r--r--generic/tclProc.c9
-rw-r--r--generic/tclUtil.c34
9 files changed, 140 insertions, 72 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 20b37dc..9691459 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.22 1999/11/19 06:34:22 hobbs Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.23 1999/12/12 02:26:40 hobbs Exp $
*/
#include "tclInt.h"
@@ -2495,7 +2495,8 @@ Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
* Tcl_EvalObjEx --
*
* Execute Tcl commands stored in a Tcl object. These commands are
- * compiled into bytecodes if necessary.
+ * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
+ * is specified.
*
* Results:
* The return value is one of the return codes defined in tcl.h
@@ -2539,10 +2540,6 @@ Tcl_EvalObjEx(interp, objPtr, flags)
* in case TCL_EVAL_GLOBAL was set. */
Namespace *namespacePtr;
- /*
- * Prevent the object from being deleted as a side effect of evaling it.
- */
-
Tcl_IncrRefCount(objPtr);
if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {
@@ -2550,17 +2547,36 @@ Tcl_EvalObjEx(interp, objPtr, flags)
* We're not supposed to use the compiler or byte-code interpreter.
* Let Tcl_EvalEx evaluate the command directly (and probably
* more slowly).
+ *
+ * Pure List Optimization (no string representation). In this
+ * case, we can safely use Tcl_EvalObjv instead and get an
+ * appreciable improvement in execution speed. This is because it
+ * allows us to avoid a setFromAny step that would just pack
+ * everything into a string and back out again.
+ *
+ * USE_EVAL_DIRECT is a special flag used for testing purpose only
+ * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
*/
-
- char *p;
- int length;
-
- p = Tcl_GetStringFromObj(objPtr, &length);
- result = Tcl_EvalEx(interp, p, length, flags);
+ if (!(iPtr->flags & USE_EVAL_DIRECT) &&
+ (objPtr->typePtr == &tclListType) && /* is a list... */
+ (objPtr->bytes == NULL) /* ...without a string rep */) {
+ register List *listRepPtr =
+ (List *) objPtr->internalRep.otherValuePtr;
+ result = Tcl_EvalObjv(interp, listRepPtr->elemCount,
+ listRepPtr->elements, flags);
+ } else {
+ register char *p;
+ p = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ result = Tcl_EvalEx(interp, p, numSrcBytes, flags);
+ }
Tcl_DecrRefCount(objPtr);
return result;
}
+ /*
+ * Prevent the object from being deleted as a side effect of evaling it.
+ */
+
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = NULL;
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 3e4de89..731bac0 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.10 1999/10/29 03:03:59 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.11 1999/12/12 02:26:41 hobbs Exp $
*/
#include "tclInt.h"
@@ -613,17 +613,15 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv)
}
if (objc == 2) {
- result = Tcl_EvalObjEx(interp, objv[1], 0);
+ result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
} else {
/*
* More than one argument: concatenate them together with spaces
- * between, then evaluate the result.
+ * between, then evaluate the result. Tcl_EvalObjEx will delete
+ * the object when it decrements its refcount after eval'ing it.
*/
-
- objPtr = Tcl_ConcatObj(objc-1, objv+1);
- Tcl_IncrRefCount(objPtr);
- result = Tcl_EvalObjEx(interp, objPtr, 0);
- Tcl_DecrRefCount(objPtr);
+ objPtr = Tcl_ConcatObj(objc-1, objv+1);
+ result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
}
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 86ed11e..af3da2c 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.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: tclCmdMZ.c,v 1.22 1999/10/29 03:03:59 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.23 1999/12/12 02:26:41 hobbs Exp $
*/
#include "tclInt.h"
@@ -995,7 +995,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
if ((enum options) index == STR_EQUAL) {
- Tcl_SetIntObj(resultPtr, (match) ? 0 : 1);
+ Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
} else {
Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
(match < 0) ? -1 : 0));
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index cc7462b..ed7500f 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -10,7 +10,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.18 1999/12/04 06:15:40 hobbs Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.19 1999/12/12 02:26:41 hobbs Exp $
*/
#include "tclInt.h"
@@ -1700,8 +1700,7 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
char *localName = localPtr->name;
- if ((name[0] == localName[0])
- && (nameBytes == localPtr->nameLength)
+ if ((nameBytes == localPtr->nameLength)
&& (strncmp(name, localName, (unsigned) nameBytes) == 0)) {
return i;
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5262f6b..1affb53 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.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: tclExecute.c,v 1.8 1999/12/04 06:15:41 hobbs Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.9 1999/12/12 02:26:42 hobbs Exp $
*/
#include "tclInt.h"
@@ -2311,20 +2311,25 @@ TclExecuteByteCode(interp, codePtr)
tPtr = valuePtr->typePtr;
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
- char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s, length)) {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- valuePtr, &i);
+ if ((tPtr == &tclBooleanType)
+ && (valuePtr->bytes == NULL)) {
+ valuePtr->typePtr = &tclIntType;
} else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d);
- }
- if (result != TCL_OK) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
- s, (tPtr? tPtr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
- Tcl_DecrRefCount(valuePtr);
- goto checkForCatch;
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
+ result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
+ valuePtr, &i);
+ } else {
+ result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
+ valuePtr, &d);
+ }
+ if (result != TCL_OK) {
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
+ s, (tPtr? tPtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ Tcl_DecrRefCount(valuePtr);
+ goto checkForCatch;
+ }
}
tPtr = valuePtr->typePtr;
}
@@ -2495,18 +2500,24 @@ TclExecuteByteCode(interp, codePtr)
converted = 0;
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
- s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s, length)) {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- valuePtr, &i);
- } else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d);
- }
- if (result == TCL_OK) {
+ if ((tPtr == &tclBooleanType)
+ && (valuePtr->bytes == NULL)) {
+ valuePtr->typePtr = &tclIntType;
converted = 1;
+ } else {
+ s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
+ result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
+ valuePtr, &i);
+ } else {
+ result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
+ valuePtr, &d);
+ }
+ if (result == TCL_OK) {
+ converted = 1;
+ }
+ result = TCL_OK; /* reset the result variable */
}
- result = TCL_OK; /* reset the result variable */
tPtr = valuePtr->typePtr;
}
@@ -2525,18 +2536,24 @@ TclExecuteByteCode(interp, codePtr)
shared = 0;
if (Tcl_IsShared(valuePtr)) {
shared = 1;
- if (tPtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- objPtr = Tcl_NewLongObj(i);
- } else {
- d = valuePtr->internalRep.doubleValue;
- objPtr = Tcl_NewDoubleObj(d);
+ if (valuePtr->bytes != NULL) {
+ /*
+ * We only need to make a copy of the object
+ * when it already had a string rep
+ */
+ if (tPtr == &tclIntType) {
+ i = valuePtr->internalRep.longValue;
+ objPtr = Tcl_NewLongObj(i);
+ } else {
+ d = valuePtr->internalRep.doubleValue;
+ objPtr = Tcl_NewDoubleObj(d);
+ }
+ Tcl_IncrRefCount(objPtr);
+ TclDecrRefCount(valuePtr);
+ valuePtr = objPtr;
+ stackPtr[stackTop] = valuePtr;
+ tPtr = valuePtr->typePtr;
}
- Tcl_IncrRefCount(objPtr);
- TclDecrRefCount(valuePtr);
- valuePtr = objPtr;
- stackPtr[stackTop] = valuePtr;
- tPtr = valuePtr->typePtr;
} else {
Tcl_InvalidateStringRep(valuePtr);
}
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 4c12fc7..6e846c7 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.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: tclMain.c,v 1.6 1999/12/02 02:03:27 redman Exp $
+ * RCS: @(#) $Id: tclMain.c,v 1.7 1999/12/12 02:26:42 hobbs Exp $
*/
#include "tcl.h"
@@ -291,7 +291,9 @@ Tcl_Main(argc, argv, appInitProc)
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
- Tcl_SetObjLength(commandPtr, 0);
+ Tcl_DecrRefCount(commandPtr);
+ commandPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(commandPtr);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index b8b3fd5..4c4b4e5 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -19,7 +19,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.12 1999/10/05 22:45:40 hobbs Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.13 1999/12/12 02:26:42 hobbs Exp $
*/
#include "tclInt.h"
@@ -2909,13 +2909,12 @@ NamespaceEvalCmd(dummy, interp, objc, objv)
if (objc == 4) {
result = Tcl_EvalObjEx(interp, objv[3], 0);
} else {
- objPtr = Tcl_ConcatObj(objc-3, objv+3);
-
- /*
- * Tcl_EvalObj will delete the object when it decrements its
- * refcount after eval'ing it.
+ /*
+ * More than one argument: concatenate them together with spaces
+ * between, then evaluate the result. Tcl_EvalObjEx will delete
+ * the object when it decrements its refcount after eval'ing it.
*/
-
+ objPtr = Tcl_ConcatObj(objc-3, objv+3);
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
}
if (result == TCL_ERROR) {
diff --git a/generic/tclProc.c b/generic/tclProc.c
index aeb8d17..feff5a0 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.22 1999/11/19 23:02:12 hobbs Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.23 1999/12/12 02:26:42 hobbs Exp $
*/
#include "tclInt.h"
@@ -601,8 +601,13 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv)
*/
if (objc == 1) {
- result = Tcl_EvalObjEx(interp, objv[0], 0);
+ result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
} else {
+ /*
+ * More than one argument: concatenate them together with spaces
+ * between, then evaluate the result. Tcl_EvalObjEx will delete
+ * the object when it decrements its refcount after eval'ing it.
+ */
Tcl_Obj *objPtr;
objPtr = Tcl_ConcatObj(objc, objv);
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index da38b97..6e99f32 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUtil.c,v 1.16 1999/12/08 03:49:52 hobbs Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.17 1999/12/12 02:26:43 hobbs Exp $
*/
#include "tclInt.h"
@@ -1005,6 +1005,38 @@ Tcl_ConcatObj(objc, objv)
char *concatStr;
Tcl_Obj *objPtr;
+ /*
+ * Check first to see if all the items are of list type. If so,
+ * we will concat them together as lists, and return a list object.
+ * This is only valid when the lists have no current string
+ * representation, since we don't know what the original type was.
+ * An original string rep may have lost some whitespace info when
+ * converted which could be important.
+ */
+ for (i = 0; i < objc; i++) {
+ objPtr = objv[i];
+ if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) {
+ break;
+ }
+ }
+ if (i == objc) {
+ Tcl_Obj **listv;
+ int listc;
+
+ objPtr = Tcl_NewListObj(0, NULL);
+ for (i = 0; i < objc; i++) {
+ /*
+ * Tcl_ListObjAppendList could be used here, but this saves
+ * us a bit of type checking (since we've already done it)
+ * Use of INT_MAX tells us to always put the new stuff on
+ * the end. It will be set right in Tcl_ListObjReplace.
+ */
+ Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv);
+ Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv);
+ }
+ return objPtr;
+ }
+
allocSize = 0;
for (i = 0; i < objc; i++) {
objPtr = objv[i];