diff options
| -rw-r--r-- | generic/tclBasic.c | 40 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 14 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 4 | ||||
| -rw-r--r-- | generic/tclCompile.c | 5 | ||||
| -rw-r--r-- | generic/tclExecute.c | 87 | ||||
| -rw-r--r-- | generic/tclMain.c | 6 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 13 | ||||
| -rw-r--r-- | generic/tclProc.c | 9 | ||||
| -rw-r--r-- | generic/tclUtil.c | 34 |
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]; |