diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 392 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 328 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 7 | ||||
| -rw-r--r-- | generic/tclCompile.h | 8 | ||||
| -rw-r--r-- | generic/tclExecute.c | 214 | ||||
| -rw-r--r-- | generic/tclIndexObj.c | 31 | ||||
| -rw-r--r-- | generic/tclInt.h | 74 | ||||
| -rw-r--r-- | generic/tclInterp.c | 7 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 226 | ||||
| -rw-r--r-- | generic/tclObj.c | 188 | ||||
| -rw-r--r-- | generic/tclParse.c | 5 | ||||
| -rw-r--r-- | generic/tclTrace.c | 46 | ||||
| -rw-r--r-- | generic/tclVar.c | 6 |
13 files changed, 893 insertions, 639 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 60f7bb8..026dc1d 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.244.2.2 2007/06/05 18:12:41 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.244.2.3 2007/06/12 15:56:42 dgp Exp $ */ #include "tclInt.h" @@ -91,6 +91,12 @@ static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp, static void MathFuncWrongNumArgs(Tcl_Interp* interp, int expected, int actual, Tcl_Obj *const *objv); +static int FullEvalObjvInternal(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], const char *command, + int length, int flags); +static int ProcessEvalObjvReturn(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int flags, int code); + extern TclStubs tclStubs; /* @@ -144,7 +150,6 @@ static const CmdInfo builtInCmds[] = { {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, 1}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, - {"info", Tcl_InfoObjCmd, NULL, 1}, {"join", Tcl_JoinObjCmd, NULL, 1}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1}, @@ -456,7 +461,7 @@ Tcl_CreateInterp(void) result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { - Tcl_Panic("Tcl_CreateInterp: faile to push the root stack frame"); + Tcl_Panic("Tcl_CreateInterp: failed to push the root stack frame"); } framePtr->objc = 0; @@ -575,8 +580,9 @@ Tcl_CreateInterp(void) } /* - * Register clock and chan subcommands. These *do* go through - * Tcl_CreateObjCommand, since they aren't in the global namespace. + * Register "clock", "chan" and "info" subcommands. These *do* go through + * Tcl_CreateObjCommand, since they aren't in the global namespace and + * involve ensembles. */ TclClockInit(interp); @@ -588,6 +594,8 @@ Tcl_CreateInterp(void) NULL, NULL); } + TclInitInfoCmd(interp); + /* TIP #208 */ Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate", TclChanTruncateObjCmd, NULL, NULL); @@ -2271,7 +2279,7 @@ TclRenameCommand( * deleted by invocation of rename traces. */ - TclCleanupCommand(cmdPtr); + TclCleanupCommandMacro(cmdPtr); result = TCL_OK; done: @@ -2756,7 +2764,7 @@ Tcl_DeleteCommandFromToken( * looks up the command in the command hashtable). */ - TclCleanupCommand(cmdPtr); + TclCleanupCommandMacro(cmdPtr); return 0; } @@ -3377,12 +3385,21 @@ TclInterpReady( /* *---------------------------------------------------------------------- * - * TclEvalObjvInternal -- + * TclEvalObjvInternal, FullEvalObjvInternal, TclEvalObjvKnownCommand -- * - * This function evaluates a Tcl command that has already been parsed + * These functions evaluate a Tcl command that has already been parsed * into words, with one Tcl_Obj holding each word. The caller is * responsible for managing the iPtr->numLevels. * + * TclEvalObjvInternal is the backend for Tcl_EvalObjv, the other two are + * separate backends for TclEvalObjvInternal: + * - FullEvalObjvInternal is the full implementation, with [unknown] and + * trace handling. + * - TclEvalObjvKnownCommand is a fast implementation for known untraced + * commands. + * The bytecode engine calls directly into both TclEvalObjvInternal and + * TclEvalObjvKnownCommand. + * * Results: * The return value is a standard Tcl completion code such as TCL_OK or * TCL_ERROR. A result or error message is left in interp's result. If an @@ -3392,15 +3409,18 @@ TclInterpReady( * Side effects: * Depends on the command. * - * Note to maintainers: - * This function has to be kept in sync with the shortcut version in + * Notes to maintainers: + * * This function has to be kept in sync with the shortcut version in * TclExecuteByteCode (INST_INVOKE). + * * This function has been split in two: a full version that processes + * unknown an traced commands too, and a shorter one that handles the + * normal case. They have to be kept in sync. * *---------------------------------------------------------------------- */ -int -TclEvalObjvInternal( +static int +FullEvalObjvInternal( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ int objc, /* Number of words in command. */ @@ -3408,10 +3428,9 @@ TclEvalObjvInternal( * the words that make up the command. */ const char *command, /* Points to the beginning of the string * representation of the command; this is used - * for traces. If the string representation of - * the command is unknown, an empty string - * should be supplied. If it is NULL, no - * traces will be called. */ + * for traces. NULL if the string + * representation of the command is unknown is + * to be generated from (objc,objv).*/ int length, /* Number of bytes in command; if -1, all * characters up to the first null byte are * used. */ @@ -3429,17 +3448,10 @@ TclEvalObjvInternal( int code = TCL_OK; int traceCode = TCL_OK; int checkTraces = 1; + int haveTraces; Namespace *savedNsPtr = NULL; Namespace *lookupNsPtr = iPtr->lookupNsPtr; - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } - - if (objc == 0) { - return TCL_OK; - } - /* * If any execution traces rename or delete the current command, we may * need (at most) two passes here. @@ -3451,18 +3463,20 @@ TclEvalObjvInternal( * Configure evaluation context to match the requested flags. */ - if ((flags & TCL_EVAL_GLOBAL) && (varFramePtr != iPtr->rootFramePtr) - && !savedVarFramePtr) { - varFramePtr = iPtr->rootFramePtr; - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = varFramePtr; - } else if (flags & TCL_EVAL_INVOKE) { - savedNsPtr = varFramePtr->nsPtr; - if (lookupNsPtr) { - varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; - } else { - varFramePtr->nsPtr = iPtr->globalNsPtr; + if (flags) { + if (flags & TCL_EVAL_INVOKE) { + savedNsPtr = varFramePtr->nsPtr; + if (lookupNsPtr) { + varFramePtr->nsPtr = lookupNsPtr; + iPtr->lookupNsPtr = NULL; + } else { + varFramePtr->nsPtr = iPtr->globalNsPtr; + } + } else if ((flags & TCL_EVAL_GLOBAL) && (varFramePtr != iPtr->rootFramePtr) + && !savedVarFramePtr) { + varFramePtr = iPtr->rootFramePtr; + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = varFramePtr; } } @@ -3567,7 +3581,8 @@ TclEvalObjvInternal( * Call trace functions if needed. */ - if (checkTraces && (command != NULL)) { + haveTraces = (iPtr->tracePtr != NULL) || (cmdPtr->flags & CMD_HAS_EXEC_TRACES); + if (haveTraces && checkTraces) { int cmdEpoch = cmdPtr->cmdEpoch; int newEpoch; @@ -3587,7 +3602,7 @@ TclEvalObjvInternal( cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); } newEpoch = cmdPtr->cmdEpoch; - TclCleanupCommand(cmdPtr); + TclCleanupCommandMacro(cmdPtr); /* * If the traces modified/deleted the command or any existing traces, @@ -3609,7 +3624,7 @@ TclEvalObjvInternal( cmdPtr->refCount++; iPtr->cmdCount++; - if (code == TCL_OK && traceCode == TCL_OK && !Tcl_LimitExceeded(interp)) { + if (code == TCL_OK && traceCode == TCL_OK && !TclLimitExceeded(iPtr->limit)) { if (!(flags & TCL_EVAL_INVOKE) && (iPtr->ensembleRewrite.sourceObjs != NULL)) { iPtr->ensembleRewrite.sourceObjs = NULL; @@ -3619,7 +3634,7 @@ TclEvalObjvInternal( if (Tcl_AsyncReady()) { code = Tcl_AsyncInvoke(interp, code); } - if (code == TCL_OK && Tcl_LimitReady(interp)) { + if (code == TCL_OK && TclLimitReady(iPtr->limit)) { code = Tcl_LimitCheck(interp); } @@ -3627,33 +3642,90 @@ TclEvalObjvInternal( * Call 'leave' command traces */ - if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + if (haveTraces) { + if (!(cmdPtr->flags & CMD_IS_DELETED)) { + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } } - if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + + /* + * If one of the trace invocation resulted in error, then change the + * result code accordingly. Note, that the interp->result should + * already be set correctly by the call to TraceExecutionProc. + */ + + if (traceCode != TCL_OK) { + code = traceCode; } - } + } + /* * Decrement the reference count of cmdPtr and deallocate it if it has * dropped to zero. */ - TclCleanupCommand(cmdPtr); + TclCleanupCommandMacro(cmdPtr); /* - * If one of the trace invocation resulted in error, then change the - * result code accordingly. Note, that the interp->result should already - * be set correctly by the call to TraceExecutionProc. + * If the interpreter has a non-empty string result, the result object is + * either empty or stale because some function set interp->result + * directly. If so, move the string result to the result object, then + * reset the string result. */ - if (traceCode != TCL_OK) { - code = traceCode; + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); + } + + done: + if (savedVarFramePtr) { + iPtr->varFramePtr = savedVarFramePtr; } + return code; +} + +int +TclEvalObjvKnownCommand( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * command. Also used for error reporting. */ + int objc, /* Number of words in command. */ + Tcl_Obj *const objv[], /* An array of pointers to objects that are + * the words that make up the command. */ + Command *cmdPtr) /* The already determined valid command */ +{ + Interp *iPtr = (Interp *) interp; + int code = TCL_OK; + + /* + * Finally, invoke the command's Tcl_ObjCmdProc. + */ + + cmdPtr->refCount++; + iPtr->cmdCount++; + + if (!TclLimitExceeded(iPtr->limit)) { + code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + } + if (Tcl_AsyncReady()) { + code = Tcl_AsyncInvoke(interp, code); + } + if (code == TCL_OK && TclLimitReady(iPtr->limit)) { + code = Tcl_LimitCheck(interp); + } + + /* + * Decrement the reference count of cmdPtr and deallocate it if it has + * dropped to zero. + */ + + TclCleanupCommandMacro(cmdPtr); /* * If the interpreter has a non-empty string result, the result object is @@ -3666,87 +3738,134 @@ TclEvalObjvInternal( (void) Tcl_GetObjResult(interp); } - done: - if (savedVarFramePtr) { - iPtr->varFramePtr = savedVarFramePtr; - } return code; } + +int +TclEvalObjvInternal( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * command. Also used for error reporting. */ + int objc, /* Number of words in command. */ + Tcl_Obj *const objv[], /* An array of pointers to objects that are + * the words that make up the command. */ + const char *command, /* Points to the beginning of the string + * representation of the command; this is used + * for traces. NULL if the string + * representation of the command is unknown is + * to be generated from (objc,objv).*/ + int length, /* Number of bytes in command; if -1, all + * characters up to the first null byte are + * used. */ + int flags) /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are + * currently supported. */ +{ + Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + Namespace *savedNsPtr = NULL; + Namespace *lookupNsPtr = iPtr->lookupNsPtr; + + if (TclInterpReady(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + if (objc == 0) { + return TCL_OK; + } + + /* + * Configure evaluation context to match the requested flags. + */ + + if (flags) { + if (flags & TCL_EVAL_INVOKE) { + savedNsPtr = varFramePtr->nsPtr; + if (lookupNsPtr) { + varFramePtr->nsPtr = lookupNsPtr; + iPtr->lookupNsPtr = NULL; + } else { + varFramePtr->nsPtr = iPtr->globalNsPtr; + } + } else if ((flags & TCL_EVAL_GLOBAL) && (varFramePtr != iPtr->rootFramePtr)) { + /* + * Use the full version, so that this one can do optimised tail calls. + */ + + return FullEvalObjvInternal(interp, objc, objv, command, length, flags); + } + } + + /* + * Find the function to execute this command. If there isn't one, or if + * there are traces, delegate to the full version. + */ + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if (savedNsPtr) { + varFramePtr->nsPtr = savedNsPtr; + } + + if ((cmdPtr && !iPtr->tracePtr && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES))) { + if (!(flags & TCL_EVAL_INVOKE) && + (iPtr->ensembleRewrite.sourceObjs != NULL)) { + iPtr->ensembleRewrite.sourceObjs = NULL; + } + return TclEvalObjvKnownCommand(interp, objc, objv, cmdPtr); + } else { + /* + * Need the full version: command is either unknown or traced + */ + + if (lookupNsPtr) { + iPtr->lookupNsPtr = lookupNsPtr; + } + return FullEvalObjvInternal(interp, objc, objv, command, length, flags); + } +} /* *---------------------------------------------------------------------- * - * Tcl_EvalObjv -- + * ProcessEvalObjvReturn -- * - * This function evaluates a Tcl command that has already been parsed - * into words, with one Tcl_Obj holding each word. + * This function does special handling for non TCL_OK returns from + * Tcl_EvalObjv. * * Results: * The return value is a standard Tcl completion code such as TCL_OK or * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: - * Depends on the command. + * May alter the return code and/or generate an error log. * *---------------------------------------------------------------------- */ -int -Tcl_EvalObjv( +static int +ProcessEvalObjvReturn( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ int objc, /* Number of words in command. */ Tcl_Obj *const objv[], /* An array of pointers to objects that are * the words that make up the command. */ - int flags) /* Collection of OR-ed bits that control the - * evaluation of the script. Only - * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are - * currently supported. */ + int flags, + int code) /* The return code to be processed */ { Interp *iPtr = (Interp *) interp; - Trace *tracePtr; - Tcl_DString cmdBuf; - const char *cmdString = ""; /* A command string is only necessary for - * command traces or error logs; it will be - * generated to replace this default value if - * necessary. */ - int cmdLen = 0; /* A non-zero value indicates that a command - * string was generated. */ - int code = TCL_OK; - int i; int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - - for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { - if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) { - /* - * The command may be needed for an execution trace. Generate a - * command string. - */ - - Tcl_DStringInit(&cmdBuf); - for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); - } - cmdString = Tcl_DStringValue(&cmdBuf); - cmdLen = Tcl_DStringLength(&cmdBuf); - break; - } - } - - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags); - iPtr->numLevels--; - + /* * If we are again at the top level, process any unusual return code * returned by the evaluated code. */ - + if (iPtr->numLevels == 0) { if (code == TCL_RETURN) { code = TclUpdateReturnInfo(iPtr); } - if ((code != TCL_OK) && (code != TCL_ERROR) && !allowExceptions) { + if ((code != TCL_ERROR) && !allowExceptions) { ProcessUnexpectedResult(interp, code); code = TCL_ERROR; } @@ -3755,29 +3874,70 @@ Tcl_EvalObjv( if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { /* * If there was an error, a command string will be needed for the - * error log: generate it now if it was not done previously. + * error log: generate it now. Do not worry too much about doing + * it expensively. */ - - if (cmdLen == 0) { - Tcl_DStringInit(&cmdBuf); - for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); - } - cmdString = Tcl_DStringValue(&cmdBuf); - cmdLen = Tcl_DStringLength(&cmdBuf); - } + + Tcl_Obj *listPtr; + char *cmdString; + int cmdLen; + + listPtr = Tcl_NewListObj(objc, objv); + cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + Tcl_DecrRefCount(listPtr); } - if (cmdLen != 0) { - Tcl_DStringFree(&cmdBuf); - } return code; } /* *---------------------------------------------------------------------- * + * Tcl_EvalObjv -- + * + * This function evaluates a Tcl command that has already been parsed + * into words, with one Tcl_Obj holding each word. + * + * Results: + * The return value is a standard Tcl completion code such as TCL_OK or + * TCL_ERROR. A result or error message is left in interp's result. + * + * Side effects: + * Depends on the command. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalObjv( + Tcl_Interp *interp, /* Interpreter in which to evaluate the + * command. Also used for error reporting. */ + int objc, /* Number of words in command. */ + Tcl_Obj *const objv[], /* An array of pointers to objects that are + * the words that make up the command. */ + int flags) /* Collection of OR-ed bits that control the + * evaluation of the script. Only + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are + * currently supported. */ +{ + Interp *iPtr = (Interp *) interp; + int code = TCL_OK; + + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objc, objv, NULL, 0, flags); + iPtr->numLevels--; + + if (code == TCL_OK) { + return code; + } else { + return ProcessEvalObjvReturn(interp, objc, objv, flags, code); + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_EvalTokensStandard -- * * Given an array of tokens parsed from a Tcl command (e.g., the tokens diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index cdda071..cf3270c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,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.115 2007/05/05 23:33:13 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.115.2.1 2007/06/12 15:56:42 dgp Exp $ */ #include "tclInt.h" @@ -153,6 +153,40 @@ static int SortCompare(Tcl_Obj *firstPtr, Tcl_Obj *second, SortInfo *infoPtr); static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, SortInfo *infoPtr); + +/* + * Array of values describing how to implement each standard subcommand of the + * "info" command. + */ + +static const struct { + const char *name; /* The name of the subcommand. */ + Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */ +} defaultInfoMap[] = { + {"args", InfoArgsCmd}, + {"body", InfoBodyCmd}, + {"cmdcount", InfoCmdCountCmd}, + {"commands", InfoCommandsCmd}, + {"complete", InfoCompleteCmd}, + {"default", InfoDefaultCmd}, + {"exists", InfoExistsCmd}, + {"frame", InfoFrameCmd}, + {"functions", InfoFunctionsCmd}, + {"globals", InfoGlobalsCmd}, + {"hostname", InfoHostnameCmd}, + {"level", InfoLevelCmd}, + {"library", InfoLibraryCmd}, + {"loaded", InfoLoadedCmd}, + {"locals", InfoLocalsCmd}, + {"nameofexecutable",InfoNameOfExecutableCmd}, + {"patchlevel", InfoPatchLevelCmd}, + {"procs", InfoProcsCmd}, + {"script", InfoScriptCmd}, + {"sharedlibextension", InfoSharedlibCmd}, + {"tclversion", InfoTclVersionCmd}, + {"vars", InfoVarsCmd}, + {NULL, NULL} +}; /* *---------------------------------------------------------------------- @@ -345,124 +379,52 @@ Tcl_IncrObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_InfoObjCmd -- + * TclInitInfoCmd -- * - * This procedure is invoked to process the "info" Tcl command. See the - * user documentation for details on what it does. + * This function is called to create the "info" Tcl command. See the user + * documentation for details on what it does. * * Results: - * A standard Tcl result. + * FIXME * * Side effects: - * See the user documentation. + * none * *---------------------------------------------------------------------- */ -int -Tcl_InfoObjCmd( - ClientData clientData, /* Arbitrary value passed to the command. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ +Tcl_Command +TclInitInfoCmd( + Tcl_Interp *interp) /* Current interpreter. */ { - static CONST char *subCmds[] = { - "args", "body", "cmdcount", "commands", - "complete", "default", "exists", "frame", "functions", - "globals", "hostname", "level", "library", "loaded", - "locals", "nameofexecutable", "patchlevel", "procs", - "script", "sharedlibextension", "tclversion", "vars", - NULL}; - enum ISubCmdIdx { - IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, - ICompleteIdx, IDefaultIdx, IExistsIdx, IFrameIdx, IFunctionsIdx, - IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, - ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, - IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx - }; - int index, result; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); - return TCL_ERROR; - } - - result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, - (int *) &index); - if (result != TCL_OK) { - return result; - } - - switch (index) { - case IArgsIdx: - result = InfoArgsCmd(clientData, interp, objc, objv); - break; - case IBodyIdx: - result = InfoBodyCmd(clientData, interp, objc, objv); - break; - case ICmdCountIdx: - result = InfoCmdCountCmd(clientData, interp, objc, objv); - break; - case ICommandsIdx: - result = InfoCommandsCmd(clientData, interp, objc, objv); - break; - case ICompleteIdx: - result = InfoCompleteCmd(clientData, interp, objc, objv); - break; - case IDefaultIdx: - result = InfoDefaultCmd(clientData, interp, objc, objv); - break; - case IExistsIdx: - result = InfoExistsCmd(clientData, interp, objc, objv); - break; - case IFrameIdx: - /* TIP #280 - New method 'frame' */ - result = InfoFrameCmd(clientData, interp, objc, objv); - break; - case IFunctionsIdx: - result = InfoFunctionsCmd(clientData, interp, objc, objv); - break; - case IGlobalsIdx: - result = InfoGlobalsCmd(clientData, interp, objc, objv); - break; - case IHostnameIdx: - result = InfoHostnameCmd(clientData, interp, objc, objv); - break; - case ILevelIdx: - result = InfoLevelCmd(clientData, interp, objc, objv); - break; - case ILibraryIdx: - result = InfoLibraryCmd(clientData, interp, objc, objv); - break; - case ILoadedIdx: - result = InfoLoadedCmd(clientData, interp, objc, objv); - break; - case ILocalsIdx: - result = InfoLocalsCmd(clientData, interp, objc, objv); - break; - case INameOfExecutableIdx: - result = InfoNameOfExecutableCmd(clientData, interp, objc, objv); - break; - case IPatchLevelIdx: - result = InfoPatchLevelCmd(clientData, interp, objc, objv); - break; - case IProcsIdx: - result = InfoProcsCmd(clientData, interp, objc, objv); - break; - case IScriptIdx: - result = InfoScriptCmd(clientData, interp, objc, objv); - break; - case ISharedLibExtensionIdx: - result = InfoSharedlibCmd(clientData, interp, objc, objv); - break; - case ITclVersionIdx: - result = InfoTclVersionCmd(clientData, interp, objc, objv); - break; - case IVarsIdx: - result = InfoVarsCmd(clientData, interp, objc, objv); - break; + Tcl_Command ensemble; /* The overall ensemble. */ + Tcl_Namespace *tclNsPtr; /* Reference to the "::tcl" namespace. */ + + tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL, + TCL_CREATE_NS_IF_UNKNOWN); + if (tclNsPtr == NULL) { + Tcl_Panic("unable to find or create ::tcl namespace!"); + } + ensemble = Tcl_CreateEnsemble(interp, "::info", tclNsPtr, + TCL_ENSEMBLE_PREFIX); + if (ensemble != NULL) { + Tcl_Obj *mapDict; + int i; + + TclNewObj(mapDict); + for (i=0 ; defaultInfoMap[i].name != NULL ; i++) { + Tcl_Obj *fromObj, *toObj; + + fromObj = Tcl_NewStringObj(defaultInfoMap[i].name, -1); + TclNewLiteralStringObj(toObj, "::tcl::Info_"); + Tcl_AppendToObj(toObj, defaultInfoMap[i].name, -1); + Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); + Tcl_CreateObjCommand(interp, TclGetString(toObj), + defaultInfoMap[i].proc, NULL, NULL); + } + Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); } - return result; + return ensemble; } /* @@ -498,12 +460,12 @@ InfoArgsCmd( CompiledLocal *localPtr; Tcl_Obj *listObjPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procname"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "procname"); return TCL_ERROR; } - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); @@ -558,12 +520,12 @@ InfoBodyCmd( Proc *procPtr; Tcl_Obj *bodyPtr, *resultPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procname"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "procname"); return TCL_ERROR; } - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { Tcl_AppendResult(interp, "\"", name, "\" isn't a procedure", NULL); @@ -624,8 +586,8 @@ InfoCmdCountCmd( { Interp *iPtr = (Interp *) interp; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -681,11 +643,11 @@ InfoCommandsCmd( * commands. */ - if (objc == 2) { + if (objc == 1) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; - } else if (objc == 3) { + } else if (objc == 2) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error @@ -696,7 +658,7 @@ InfoCommandsCmd( Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = TclGetString(objv[2]); + pattern = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); @@ -704,7 +666,7 @@ InfoCommandsCmd( specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -941,13 +903,13 @@ InfoCompleteCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "command"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - TclObjCommandComplete(objv[2]))); + TclObjCommandComplete(objv[1]))); return TCL_OK; } @@ -984,13 +946,13 @@ InfoDefaultCmd( CompiledLocal *localPtr; Tcl_Obj *valueObjPtr; - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "procname arg varname"); return TCL_ERROR; } - procName = TclGetString(objv[2]); - argName = TclGetString(objv[3]); + procName = TclGetString(objv[1]); + argName = TclGetString(objv[2]); procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { @@ -1003,7 +965,7 @@ InfoDefaultCmd( if (TclIsVarArgument(localPtr) && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { - valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, + valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, localPtr->defValuePtr, 0); if (valueObjPtr == NULL) { goto defStoreError; @@ -1011,7 +973,7 @@ InfoDefaultCmd( Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); - valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, + valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, nullObjPtr, 0); if (valueObjPtr == NULL) { goto defStoreError; @@ -1027,7 +989,7 @@ InfoDefaultCmd( return TCL_ERROR; defStoreError: - varName = TclGetString(objv[4]); + varName = TclGetString(objv[3]); Tcl_AppendResult(interp, "couldn't store default value in variable \"", varName, "\"", NULL); return TCL_ERROR; @@ -1063,12 +1025,12 @@ InfoExistsCmd( char *varName; Var *varPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "varName"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName"); return TCL_ERROR; } - varName = TclGetString(objv[2]); + varName = TclGetString(objv[1]); varPtr = TclVarTraceExists(interp, varName); Tcl_SetObjResult(interp, Tcl_NewBooleanObj( @@ -1119,7 +1081,7 @@ InfoFrameCmd( }; Tcl_Obj *tmpObj; - if (objc == 2) { + if (objc == 1) { /* * Just "info frame". */ @@ -1129,8 +1091,8 @@ InfoFrameCmd( Tcl_SetIntObj(Tcl_GetObjResult(interp), levels); return TCL_OK; - } else if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?number?"); + } else if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); return TCL_ERROR; } @@ -1138,7 +1100,7 @@ InfoFrameCmd( * We've got "info frame level" and must parse the level first. */ - if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[1], &level) != TCL_OK) { return TCL_ERROR; } if (level <= 0) { @@ -1150,7 +1112,7 @@ InfoFrameCmd( if (iPtr->cmdFramePtr == NULL) { levelError: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"", - TclGetString(objv[2]), "\"", NULL); + TclGetString(objv[1]), "\"", NULL); return TCL_ERROR; } @@ -1375,12 +1337,12 @@ InfoFunctionsCmd( { char *pattern; - if (objc == 2) { + if (objc == 1) { pattern = NULL; - } else if (objc == 3) { - pattern = TclGetString(objv[2]); + } else if (objc == 2) { + pattern = TclGetString(objv[1]); } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -1423,10 +1385,10 @@ InfoGlobalsCmd( Var *varPtr; Tcl_Obj *listPtr; - if (objc == 2) { + if (objc == 1) { pattern = NULL; - } else if (objc == 3) { - pattern = TclGetString(objv[2]); + } else if (objc == 2) { + pattern = TclGetString(objv[1]); /* * Strip leading global-namespace qualifiers. [Bug 1057461] @@ -1438,7 +1400,7 @@ InfoGlobalsCmd( } } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -1505,8 +1467,8 @@ InfoHostnameCmd( { CONST char *name; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1548,16 +1510,16 @@ InfoLevelCmd( { Interp *iPtr = (Interp *) interp; - if (objc == 2) { /* Just "info level" */ + if (objc == 1) { /* Just "info level" */ Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level)); return TCL_OK; } - if (objc == 3) { + if (objc == 2) { int level; CallFrame *framePtr, *rootFramePtr = iPtr->rootFramePtr; - if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[1], &level) != TCL_OK) { return TCL_ERROR; } if (level <= 0) { @@ -1581,11 +1543,11 @@ InfoLevelCmd( return TCL_OK; } - Tcl_WrongNumArgs(interp, 2, objv, "?number?"); + Tcl_WrongNumArgs(interp, 1, objv, "?number?"); return TCL_ERROR; levelError: - Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[2]), "\"", + Tcl_AppendResult(interp, "bad level \"", TclGetString(objv[1]), "\"", NULL); return TCL_ERROR; } @@ -1620,8 +1582,8 @@ InfoLibraryCmd( { CONST char *libDirName; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1665,15 +1627,15 @@ InfoLoadedCmd( char *interpName; int result; - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - if (objc == 2) { /* Get loaded pkgs in all interpreters. */ + if (objc == 1) { /* Get loaded pkgs in all interpreters. */ interpName = NULL; } else { /* Get pkgs just in specified interp. */ - interpName = TclGetString(objv[2]); + interpName = TclGetString(objv[1]); } result = TclGetLoadedPackages(interp, interpName); return result; @@ -1711,12 +1673,12 @@ InfoLocalsCmd( char *pattern; Tcl_Obj *listPtr; - if (objc == 2) { + if (objc == 1) { pattern = NULL; - } else if (objc == 3) { - pattern = TclGetString(objv[2]); + } else if (objc == 2) { + pattern = TclGetString(objv[1]); } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -1863,8 +1825,8 @@ InfoNameOfExecutableCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclGetObjNameOfExecutable()); @@ -1901,8 +1863,8 @@ InfoPatchLevelCmd( { CONST char *patchlevel; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -1964,11 +1926,11 @@ InfoProcsCmd( * procs. */ - if (objc == 2) { + if (objc == 1) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; - } else if (objc == 3) { + } else if (objc == 2) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error @@ -1979,7 +1941,7 @@ InfoProcsCmd( Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = TclGetString(objv[2]); + pattern = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); @@ -1988,7 +1950,7 @@ InfoProcsCmd( specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } @@ -2135,16 +2097,16 @@ InfoScriptCmd( Tcl_Obj *CONST objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?filename?"); + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?filename?"); return TCL_ERROR; } - if (objc == 3) { + if (objc == 2) { if (iPtr->scriptFile != NULL) { Tcl_DecrRefCount(iPtr->scriptFile); } - iPtr->scriptFile = objv[2]; + iPtr->scriptFile = objv[1]; Tcl_IncrRefCount(iPtr->scriptFile); } if (iPtr->scriptFile != NULL) { @@ -2181,8 +2143,8 @@ InfoSharedlibCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -2221,8 +2183,8 @@ InfoTclVersionCmd( { Tcl_Obj *version; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -2284,11 +2246,11 @@ InfoVarsCmd( * Tcl procedure frame. */ - if (objc == 2) { + if (objc == 1) { simplePattern = NULL; nsPtr = currNsPtr; specificNsInPattern = 0; - } else if (objc == 3) { + } else if (objc == 2) { /* * From the pattern, get the effective namespace and the simple * pattern (no namespace qualifiers or ::'s) at the end. If an error @@ -2299,7 +2261,7 @@ InfoVarsCmd( Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = TclGetString(objv[2]); + pattern = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); @@ -2308,7 +2270,7 @@ InfoVarsCmd( specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); return TCL_ERROR; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 274d8af..13a87b3 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,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.150 2007/05/01 20:20:44 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.150.2.1 2007/06/12 15:56:42 dgp Exp $ */ #include "tclInt.h" @@ -1286,7 +1286,8 @@ Tcl_StringObjCmd( int match, start; if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2,objv, "subString string ?startIndex?"); + Tcl_WrongNumArgs(interp, 2, objv, + "needleString haystackString ?startIndex?"); return TCL_ERROR; } @@ -1745,7 +1746,7 @@ Tcl_StringObjCmd( if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, - "subString string ?startIndex?"); + "needleString haystackString ?startIndex?"); return TCL_ERROR; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index f8ddfb2..a5cd143 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.70.2.1 2007/05/30 18:38:46 dgp Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.70.2.2 2007/06/12 15:56:42 dgp Exp $ */ #ifndef _TCLCOMPILATION @@ -806,9 +806,11 @@ typedef struct { */ MODULE_SCOPE int TclEvalObjvInternal(Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], + int objc, Tcl_Obj *const objv[], CONST char *command, int length, int flags); - +MODULE_SCOPE int TclEvalObjvKnownCommand(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[], + Command *cmdPtr); /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 18ea0b2..b9dcc6f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.285.2.1 2007/06/05 18:12:41 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.285.2.2 2007/06/12 15:56:42 dgp Exp $ */ #include "tclInt.h" @@ -119,6 +119,65 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ /* + * Support pre-8.5 bytecodes unless specifically requested otherwise + */ + +#ifndef TCL_SUPPORT_84_BYTECODE +#define TCL_SUPPORT_84_BYTECODE 1 +#endif + +#if TCL_SUPPORT_84_BYTECODE +/* + * We need to know the tclBuiltinFuncTable to support translation of pre-8.5 + * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+. + */ + +typedef struct { + char *name; /* Name of function. */ + int numArgs; /* Number of arguments for function. */ +} BuiltinFunc; + +/* + * Table describing the built-in math functions. Entries in this table are + * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's + * operand byte. + */ + +static BuiltinFunc tclBuiltinFuncTable[] = { + {"acos", 1}, + {"asin", 1}, + {"atan", 1}, + {"atan2", 2}, + {"ceil", 1}, + {"cos", 1}, + {"cosh", 1}, + {"exp", 1}, + {"floor", 1}, + {"fmod", 2}, + {"hypot", 2}, + {"log", 1}, + {"log10", 1}, + {"pow", 2}, + {"sin", 1}, + {"sinh", 1}, + {"sqrt", 1}, + {"tan", 1}, + {"tanh", 1}, + {"abs", 1}, + {"double", 1}, + {"int", 1}, + {"rand", 0}, + {"round", 1}, + {"srand", 1}, + {"wide", 1}, + {0}, +}; + +#define LAST_BUILTIN_FUNC 25 + +#endif + +/* * The new macro for ending an instruction; note that a reasonable C-optimiser * will resolve all branches at compile time. (result) is always a constant; * the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved @@ -343,26 +402,6 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* - * Inline version of Tcl_LimitReady() to limit number of calls out of this - * file in the critical path. Note that this code isn't particularly readable; - * the non-inline version (in tclInterp.c) is much easier to understand. Note - * also that this macro takes different args (iPtr->limit) to the non-inline - * version. - */ - -#define TclLimitReady(limit) \ - (((limit).active == 0) ? 0 : \ - (++(limit).granularityTicker, \ - ((((limit).active & TCL_LIMIT_COMMANDS) && \ - (((limit).cmdGranularity == 1) || \ - ((limit).granularityTicker % (limit).cmdGranularity == 0))) \ - ? 1 : \ - (((limit).active & TCL_LIMIT_TIME) && \ - (((limit).timeGranularity == 1) || \ - ((limit).granularityTicker % (limit).timeGranularity == 0)))\ - ? 1 : 0))) - -/* * Custom object type only used in this file; values of its type should never * be seen by user scripts. */ @@ -1058,7 +1097,10 @@ TclCompEvalObj( Namespace *namespacePtr; /* - * Check that the interpreter is ready to execute scripts + * Check that the interpreter is ready to execute scripts. Note that we + * manage the interp's runlevel here: it is a small white lie (maybe), but + * saves a ++/-- pair at each invocation. Amazingly enough, the impact on + * performance is noticeable. */ iPtr->numLevels++; @@ -1646,26 +1688,7 @@ TclExecuteByteCode( iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); if (!checkInterp) { instStartCmdOK: -#if 0 && !TCL_COMPILE_DEBUG - /* - * Peephole optimisations: check if there are several - * INST_START_CMD in a row. Many commands start by pushing a - * literal argument or command name; optimise that case too. - * - * TODO: Compiler no longer generates sequences of INST_START_CMD, - * so maybe take some of this peephole out. - */ - - while (*(pc += 9) == INST_START_CMD) { - iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); - } - if (*pc == INST_PUSH1) { - goto instPush1Peephole; - } - NEXT_INST_F(0, 0, 0); -#else NEXT_INST_F(9, 0, 0); -#endif } else if (((codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsEpoch == namespacePtr->resolverEpoch)) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { @@ -1902,8 +1925,6 @@ TclExecuteByteCode( doInvocation: { Tcl_Obj **objv = &OBJ_AT_DEPTH(objc-1); - int length; - const char *bytes; Command *cmdPtr; #ifdef TCL_COMPILE_DEBUG @@ -1951,27 +1972,18 @@ TclExecuteByteCode( && (!checkInterp || (codePtr->compileEpoch == iPtr->compileEpoch))) { /* - * No traces, the interp is ok: avoid the call out to TEOVi + * No traces, the interp is ok: use the fast interface */ - cmdPtr->refCount++; - iPtr->cmdCount++; - iPtr->ensembleRewrite.sourceObjs = NULL; - result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, - objc, objv); - TclCleanupCommand(cmdPtr); - if (Tcl_AsyncReady()) { - result = Tcl_AsyncInvoke(interp, result); - } - if (result == TCL_OK && TclLimitReady(iPtr->limit)) { - result = Tcl_LimitCheck(interp); - } + result = TclEvalObjvKnownCommand(interp, objc, objv, cmdPtr); } else { /* * If trace procedures will be called, we need a command * string to pass to TclEvalObjvInternal; note that a copy of * the string will be made there to include the ending \0. */ + int length; + const char *bytes; bytes = GetSrcInfoForPc(pc, codePtr, &length); result = TclEvalObjvInternal(interp, objc, objv, bytes, @@ -2016,6 +2028,86 @@ TclExecuteByteCode( goto processExceptionReturn; } } + +#if TCL_SUPPORT_84_BYTECODE + case INST_CALL_BUILTIN_FUNC1: { + /* + * Call one of the built-in pre-8.5 Tcl math functions. + * This translates to INST_INVOKE_STK1 with the first argument of + * ::tcl::mathfunc::$objv[0]. We need to insert the named math + * function into the stack. + */ + int opnd, numArgs; + Tcl_Obj *objPtr; + + opnd = TclGetUInt1AtPtr(pc+1); + if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { + TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); + Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); + } + + objPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17); + Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); + + /* only 0, 1 or 2 args */ + numArgs = tclBuiltinFuncTable[opnd].numArgs; + if (numArgs == 0) { + PUSH_OBJECT(objPtr); + } else if (numArgs == 1) { + Tcl_Obj *tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + Tcl_DecrRefCount(tmpPtr1); + } else { + Tcl_Obj *tmpPtr1, *tmpPtr2; + tmpPtr2 = POP_OBJECT(); + tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + PUSH_OBJECT(tmpPtr2); + Tcl_DecrRefCount(tmpPtr1); + Tcl_DecrRefCount(tmpPtr2); + } + + objc = numArgs + 1; + pcAdjustment = 2; + goto doInvocation; + } + + case INST_CALL_FUNC1: { + /* + * Call a non-builtin Tcl math function previously registered by a + * call to Tcl_CreateMathFunc pre-8.5. + * This is essentially INST_INVOKE_STK1 converting the first arg + * to ::tcl::mathfunc::$objv[0]. + */ + Tcl_Obj *tmpPtr, *objPtr; + + /* Number of arguments. The function name is the 0-th argument. */ + objc = TclGetUInt1AtPtr(pc+1); + + objPtr = OBJ_AT_DEPTH(objc-1); + tmpPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17); + Tcl_AppendObjToObj(tmpPtr, objPtr); + Tcl_DecrRefCount(objPtr); + /* variation of PUSH_OBJECT */ + OBJ_AT_DEPTH(objc-1) = tmpPtr; + Tcl_IncrRefCount(tmpPtr); + + pcAdjustment = 2; + goto doInvocation; + } +#else + /* + * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the + * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support + * remains for existing bytecode precompiled files. + */ + case INST_CALL_BUILTIN_FUNC1: + Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); + case INST_CALL_FUNC1: + Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found"); +#endif } case INST_EVAL_STK: { @@ -5616,14 +5708,6 @@ TclExecuteByteCode( } } - case INST_CALL_BUILTIN_FUNC1: { - Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); - } - - case INST_CALL_FUNC1: { - Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found"); - } - case INST_UPLUS: case INST_TRY_CVT_TO_NUMERIC: { /* @@ -6613,7 +6697,7 @@ TclExecuteByteCode( * is not exceeded) or we get to the top-level. */ - if (Tcl_LimitExceeded(interp)) { + if (TclLimitExceeded(iPtr->limit)) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... limit exceeded, returning %s\n", diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index af0b444..c601ea0 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.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: tclIndexObj.c,v 1.32 2007/04/02 18:48:03 dgp Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.32.2.1 2007/06/12 15:56:42 dgp Exp $ */ #include "tclInt.h" @@ -449,9 +449,8 @@ Tcl_WrongNumArgs( { Tcl_Obj *objPtr; int i, len, elemLen, flags; - register IndexRep *indexRep; Interp *iPtr = (Interp *) interp; - char *elementStr; + const char *elementStr; /* * [incr Tcl] does something fairly horrific when generating error @@ -521,11 +520,25 @@ Tcl_WrongNumArgs( * Add the element, quoting it if necessary. */ - elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen); + if (origObjv[i]->typePtr == &indexType) { + register IndexRep *indexRep = + origObjv[i]->internalRep.otherValuePtr; + + elementStr = EXPAND_OF(indexRep); + elemLen = strlen(elementStr); + } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) { + register EnsembleCmdRep *ecrPtr = + origObjv[i]->internalRep.otherValuePtr; + + elementStr = ecrPtr->fullSubcmdName; + elemLen = strlen(elementStr); + } else { + elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen); + } len = Tcl_ScanCountedElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, (unsigned) len); + char *quotedElementStr = TclStackAlloc(interp, (unsigned)len); len = Tcl_ConvertCountedElement(elementStr, elemLen, quotedElementStr, flags); @@ -562,8 +575,14 @@ Tcl_WrongNumArgs( */ if (objv[i]->typePtr == &indexType) { - indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr; + register IndexRep *indexRep = objv[i]->internalRep.otherValuePtr; + Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); + } else if (objv[i]->typePtr == &tclEnsembleCmdType) { + register EnsembleCmdRep *ecrPtr = + objv[i]->internalRep.otherValuePtr; + + Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). diff --git a/generic/tclInt.h b/generic/tclInt.h index 1d8a81e..7517aa1 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.310.2.2 2007/06/05 18:12:42 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.310.2.3 2007/06/12 15:56:43 dgp Exp $ */ #ifndef _TCLINT @@ -357,6 +357,27 @@ struct NamespacePathEntry { #define TCL_FIND_ONLY_NS 0x1000 /* + * The data cached in an ensemble subcommand's Tcl_Obj rep (reference in + * otherValuePtr field). This structure is not shared between Tcl_Objs + * referring to the same subcommand, even where one is a duplicate of another. + */ + +typedef struct { + Namespace *nsPtr; /* The namespace backing the ensemble which + * this is a subcommand of. */ + int epoch; /* Used to confirm when the data in this + * really structure matches up with the + * ensemble. */ + Tcl_Command token; /* Reference to the comamnd for which this + * structure is a cache of the resolution. */ + char *fullSubcmdName; /* The full (local) name of the subcommand, + * allocated with ckalloc(). */ + Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the + * command that implements this ensemble + * subcommand. */ +} EnsembleCmdRep; + +/* *---------------------------------------------------------------- * Data structures related to variables. These are used primarily in tclVar.c *---------------------------------------------------------------- @@ -2195,6 +2216,7 @@ MODULE_SCOPE Tcl_ObjType tclProcBodyType; MODULE_SCOPE Tcl_ObjType tclStringType; MODULE_SCOPE Tcl_ObjType tclArraySearchType; MODULE_SCOPE Tcl_ObjType tclNsNameType; +MODULE_SCOPE Tcl_ObjType tclEnsembleCmdType; #ifndef NO_WIDE_TYPE MODULE_SCOPE Tcl_ObjType tclWideIntType; #endif @@ -2589,9 +2611,7 @@ MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -MODULE_SCOPE int Tcl_InfoObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); +MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]); @@ -3403,6 +3423,52 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum, #define TclIsNaN(d) ((d) != (d)) #endif +/* + *---------------------------------------------------------------- + * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace + */ + +#define TclGetCurrentNamespace(interp) \ + (Tcl_Namespace *) ((Interp *)(interp))->varFramePtr->nsPtr + +#define TclGetGlobalNamespace(interp) \ + (Tcl_Namespace *) ((Interp *)(interp))->globalNsPtr + +/* + *---------------------------------------------------------------- + * Inline version of TclCleanupCommand; still need the function as it is in + * the internal stubs, but the core can use the macro instead. + */ + +#define TclCleanupCommandMacro(cmdPtr) \ + if (--(cmdPtr)->refCount <= 0) { \ + ckfree((char *) (cmdPtr));\ + } + +/* + *---------------------------------------------------------------- + * Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number + * of calls out of the critical path. Note that this code isn't particularly + * readable; the non-inline version (in tclInterp.c) is much easier to + * understand. Note also that these macros takes different args (iPtr->limit) + * to the non-inline version. + */ + +#define TclLimitExceeded(limit) ((limit).exceeded != 0) + +#define TclLimitReady(limit) \ + (((limit).active == 0) ? 0 : \ + (++(limit).granularityTicker, \ + ((((limit).active & TCL_LIMIT_COMMANDS) && \ + (((limit).cmdGranularity == 1) || \ + ((limit).granularityTicker % (limit).cmdGranularity == 0))) \ + ? 1 : \ + (((limit).active & TCL_LIMIT_TIME) && \ + (((limit).timeGranularity == 1) || \ + ((limit).granularityTicker % (limit).timeGranularity == 0)))\ + ? 1 : 0))) + + #include "tclPort.h" #include "tclIntDecls.h" #include "tclIntPlatDecls.h" diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 8c32150..68c7bd4 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.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: tclInterp.c,v 1.74 2007/05/17 12:05:22 dkf Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.74.2.1 2007/06/12 15:56:43 dgp Exp $ */ #include "tclInt.h" @@ -2904,6 +2904,9 @@ Tcl_MakeSafe( * Side effects: * None. * + * Notes: + * If you change this function, you MUST also update TclLimitExceeded() in + * tclInt.h. *---------------------------------------------------------------------- */ @@ -2933,7 +2936,7 @@ Tcl_LimitExceeded( * * Notes: * If you change this function, you MUST also update TclLimitReady() in - * tclExecute.c. + * tclInt.h. * *---------------------------------------------------------------------- */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 9141750..d2ba828 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -22,7 +22,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.134.2.1 2007/06/05 18:12:42 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.134.2.2 2007/06/12 15:56:43 dgp Exp $ */ #include "tclInt.h" @@ -68,7 +68,8 @@ typedef struct ResolvedNsName { * a new one created at the same address). */ Namespace *refNsPtr; /* Points to the namespace containing the * reference (not the namespace that contains - * the referenced namespace). */ + * the referenced namespace). NULL if the name + * is fully qualified.*/ int refCount; /* Reference count: 1 for each nsName object * that has a pointer to this ResolvedNsName * structure as its internal rep. This @@ -153,27 +154,6 @@ typedef struct EnsembleConfig { * and on its way out. */ /* - * The data cached in a subcommand's Tcl_Obj rep. This structure is not shared - * between Tcl_Objs referring to the same subcommand, even where one is a - * duplicate of another. - */ - -typedef struct EnsembleCmdRep { - Namespace *nsPtr; /* The namespace backing the ensemble which - * this is a subcommand of. */ - int epoch; /* Used to confirm when the data in this - * really structure matches up with the - * ensemble. */ - Tcl_Command token; /* Reference to the comamnd for which this - * structure is a cache of the resolution. */ - char *fullSubcmdName; /* The full (local) name of the subcommand, - * allocated with ckalloc(). */ - Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the - * command that implements this ensemble - * subcommand. */ -} EnsembleCmdRep; - -/* * Declarations for functions local to this file: */ @@ -274,7 +254,7 @@ Tcl_ObjType tclNsNameType = { * that implements it. */ -static Tcl_ObjType ensembleCmdType = { +Tcl_ObjType tclEnsembleCmdType = { "ensembleCommand", /* the type's name */ FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ @@ -328,11 +308,7 @@ Tcl_GetCurrentNamespace( register Tcl_Interp *interp)/* Interpreter whose current namespace is * being queried. */ { - register Interp *iPtr = (Interp *) interp; - register Namespace *nsPtr; - - nsPtr = iPtr->varFramePtr->nsPtr; - return (Tcl_Namespace *) nsPtr; + return TclGetCurrentNamespace(interp); } /* @@ -356,9 +332,7 @@ Tcl_GetGlobalNamespace( register Tcl_Interp *interp)/* Interpreter whose global namespace should * be returned. */ { - register Interp *iPtr = (Interp *) interp; - - return (Tcl_Namespace *) iPtr->globalNsPtr; + return TclGetGlobalNamespace(interp); } /* @@ -411,7 +385,7 @@ Tcl_PushCallFrame( register Namespace *nsPtr; if (namespacePtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; if (nsPtr->flags & NS_DEAD) { @@ -933,7 +907,7 @@ Tcl_DeleteNamespace( register Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = - (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); + (Namespace *) TclGetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; /* @@ -1259,7 +1233,7 @@ Tcl_Export( { #define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); const char *simplePattern; char *patternCpy; int neededElems, len, i; @@ -1397,7 +1371,7 @@ Tcl_AppendExportList( */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } @@ -1467,7 +1441,7 @@ Tcl_Import( */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } @@ -1739,7 +1713,7 @@ Tcl_ForgetImport( */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } @@ -2390,11 +2364,11 @@ Tcl_FindCommand( */ if (flags & TCL_GLOBAL_ONLY) { - cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { - cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { @@ -2578,11 +2552,11 @@ Tcl_FindNamespaceVar( */ if ((flags & TCL_GLOBAL_ONLY) != 0) { - cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { - cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { @@ -2682,7 +2656,7 @@ TclResetShadowedCmdRefs( Tcl_HashEntry *hPtr; register Namespace *nsPtr; Namespace *trailNsPtr, *shadowNsPtr; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); int found, i; /* @@ -2830,76 +2804,48 @@ TclGetNamespaceFromObj( * namespace. */ Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ { - Interp *iPtr = (Interp *) interp; - register ResolvedNsName *resNamePtr; - register Namespace *nsPtr; - Namespace *currNsPtr; - CallFrame *savedFramePtr; + ResolvedNsName *resPtr; + Namespace *nsPtr; int result = TCL_OK; - char *name; - - /* - * If the namespace name is fully qualified, do as if the lookup were done - * from the global namespace; this helps avoid repeated lookups of fully - * qualified names. - */ - - savedFramePtr = iPtr->varFramePtr; - name = TclGetString(objPtr); - if ((*name++ == ':') && (*name == ':')) { - iPtr->varFramePtr = iPtr->rootFramePtr; - } - - currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - + /* * Get the internal representation, converting to a namespace type if * needed. The internal representation is a ResolvedNsName that points to * the actual namespace. - */ - - if (objPtr->typePtr != &tclNsNameType) { - result = tclNsNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - goto done; - } - } - resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; - - /* + * * Check the context namespace of the resolved symbol to make sure that it - * is fresh. If not, then force another conversion to the namespace type, - * to discard the old rep and create a new one. Note that we verify that - * the namespace id of the cached namespace is the same as the id when we - * cached it; this insures that the namespace wasn't deleted and a new one - * created at the same address. + * is fresh. Note that we verify that the namespace id of the context + * namespace is the same as the one we cached; this insures that the + * namespace wasn't deleted and a new one created at the same + * address. Note that fully qualified names have a NULL refNsPtr, these + * checks needn't be made. + * + * If any check fails, then force another conversion to the command type, + * to discard the old rep and create a new one. */ - nsPtr = NULL; - if ((resNamePtr != NULL) && (resNamePtr->refNsPtr == currNsPtr) - && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { - nsPtr = resNamePtr->nsPtr; - if (nsPtr->flags & NS_DEAD) { - nsPtr = NULL; - } - } - if (nsPtr == NULL) { /* Try again. */ + resPtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; + if ((objPtr->typePtr != &tclNsNameType) + || (resPtr == NULL) + || (resPtr->refNsPtr && + (resPtr->refNsPtr != (Namespace *) TclGetCurrentNamespace(interp))) + || (nsPtr = resPtr->nsPtr, nsPtr->flags & NS_DEAD) + || (resPtr->nsId != nsPtr->nsId)) { + result = tclNsNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - goto done; - } - resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; - if (resNamePtr != NULL) { - nsPtr = resNamePtr->nsPtr; - if (nsPtr->flags & NS_DEAD) { + + resPtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; + if ((result == TCL_OK) && resPtr) { + nsPtr = resPtr->nsPtr; + if (nsPtr && (nsPtr->flags & NS_DEAD)) { nsPtr = NULL; } + } else { + nsPtr = NULL; } } - *nsPtrPtr = (Tcl_Namespace *) nsPtr; - done: - iPtr->varFramePtr = savedFramePtr; + *nsPtrPtr = (Tcl_Namespace *) nsPtr; return result; } @@ -3071,7 +3017,7 @@ NamespaceChildrenCmd( { Tcl_Namespace *namespacePtr; Namespace *nsPtr, *childNsPtr; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); char *pattern = NULL; Tcl_DString buffer; register Tcl_HashEntry *entryPtr; @@ -3083,7 +3029,7 @@ NamespaceChildrenCmd( */ if (objc == 2) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else if ((objc == 3) || (objc == 4)) { if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { return TCL_ERROR; @@ -3233,8 +3179,8 @@ NamespaceCodeCmd( Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("inscope", -1)); - currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { + currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { TclNewLiteralStringObj(objPtr, "::"); } else { objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); @@ -3291,8 +3237,8 @@ NamespaceCurrentCmd( * namespace [namespace current]::bar { ... } */ - currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { + currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1)); @@ -3595,7 +3541,7 @@ NamespaceExportCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); char *pattern, *string; int resetListFirst = 0; int firstArg, patternCt, i, result; @@ -3789,7 +3735,7 @@ NamespaceImportCmd( Tcl_HashEntry *hPtr; Tcl_HashSearch search; - Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); Tcl_Obj *listPtr; TclNewObj(listPtr); @@ -4049,7 +3995,7 @@ NamespaceParentCmd( int result; if (objc == 2) { - nsPtr = Tcl_GetCurrentNamespace(interp); + nsPtr = TclGetCurrentNamespace(interp); } else if (objc == 3) { result = TclGetNamespaceFromObj(interp, objv[2], &nsPtr); if (result != TCL_OK) { @@ -4111,7 +4057,7 @@ NamespacePathCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); int i, nsObjc, result = TCL_ERROR; Tcl_Obj **nsObjv; Tcl_Namespace **namespaceList = NULL; @@ -4419,7 +4365,7 @@ NamespaceUnknownCmd( return TCL_ERROR; } - currNsPtr = Tcl_GetCurrentNamespace(interp); + currNsPtr = TclGetCurrentNamespace(interp); if (objc == 2) { /* @@ -4903,10 +4849,7 @@ SetNsNameFromAny( * Get the string representation. Make it up-to-date if necessary. */ - name = objPtr->bytes; - if (name == NULL) { - name = TclGetString(objPtr); - } + name = TclGetString(objPtr); /* * Look for the namespace "name" in the current namespace. If there is an @@ -4924,14 +4867,16 @@ SetNsNameFromAny( */ if (nsPtr != NULL) { - Namespace *currNsPtr = (Namespace *) - Tcl_GetCurrentNamespace(interp); - nsPtr->refCount++; resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; resNamePtr->nsId = nsPtr->nsId; - resNamePtr->refNsPtr = currNsPtr; + if ((*name++ == ':') && (*name == ':')) { + resNamePtr->refNsPtr = NULL; + } else { + resNamePtr->refNsPtr = + (Namespace *) TclGetCurrentNamespace(interp); + } resNamePtr->refCount = 1; } else { resNamePtr = NULL; @@ -5053,7 +4998,7 @@ NamespaceEnsembleCmd( }; int index; - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { Tcl_AppendResult(interp, @@ -5546,7 +5491,7 @@ Tcl_CreateEnsemble( Tcl_Obj *nameObj = NULL; if (nsPtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } /* @@ -6186,14 +6131,14 @@ NsEnsembleImplementationCmd( if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { /* * Table of subcommands is still valid; therefore there might be a - * valid cache of discovered information which we can reuse. Do the - * check here, and if we're still valid, we can jump straight to the - * part where we do the invocation of the subcommand. + * valid cache of discovered information which we can reuse. Do + * the check here, and if we're still valid, we can jump straight + * to the part where we do the invocation of the subcommand. */ - if (objv[1]->typePtr == &ensembleCmdType) { + if (objv[1]->typePtr == &tclEnsembleCmdType) { EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) - objv[1]->internalRep.otherValuePtr; + objv[1]->internalRep.otherValuePtr; if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == ensemblePtr->token) { @@ -6213,33 +6158,40 @@ NsEnsembleImplementationCmd( * then feeding it back through the main command-lookup * engine. In theory, we could look up the command in the * namespace ourselves, as we already have the namespace - * in which it is guaranteed to exist, but we don't do + * in which it is guaranteed to exist, but we don't do * that (the cacheing of the command object used should - * help with that.) + * help with that.) */ iPtr = (Interp *) interp; - isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + isRootEnsemble = + (iPtr->ensembleRewrite.sourceObjs == NULL); copyObj = TclListObjCopy(NULL, prefixObj); - Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); + Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, + &prefixObjv); if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = 2; iPtr->ensembleRewrite.numInsertedObjs = prefixObjc; } else { int ni = iPtr->ensembleRewrite.numInsertedObjs; + if (ni < 2) { iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; - iPtr->ensembleRewrite.numInsertedObjs += prefixObjc - 1; + iPtr->ensembleRewrite.numInsertedObjs += + prefixObjc - 1; } else { - iPtr->ensembleRewrite.numInsertedObjs += prefixObjc - 2; + iPtr->ensembleRewrite.numInsertedObjs += + prefixObjc - 2; } } tempObjv = (Tcl_Obj **) TclStackAlloc(interp, - (int) sizeof(Tcl_Obj *) * (objc - 2 + prefixObjc)); - memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); - memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + (int) sizeof(Tcl_Obj*) * (objc - 2 + prefixObjc)); + memcpy(tempObjv, prefixObjv, + sizeof(Tcl_Obj *) * prefixObjc); + memcpy(tempObjv+prefixObjc, objv+2, + sizeof(Tcl_Obj *) * (objc-2)); result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, TCL_EVAL_INVOKE); Tcl_DecrRefCount(copyObj); @@ -6509,7 +6461,7 @@ MakeCachedEnsembleCommand( register EnsembleCmdRep *ensembleCmd; int length; - if (objPtr->typePtr == &ensembleCmdType) { + if (objPtr->typePtr == &tclEnsembleCmdType) { ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); ensembleCmd->nsPtr->refCount--; @@ -6527,7 +6479,7 @@ MakeCachedEnsembleCommand( TclFreeIntRep(objPtr); ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); objPtr->internalRep.otherValuePtr = (void *) ensembleCmd; - objPtr->typePtr = &ensembleCmdType; + objPtr->typePtr = &tclEnsembleCmdType; } /* @@ -6959,7 +6911,7 @@ DupEnsembleCmdRep( ckalloc(sizeof(EnsembleCmdRep)); int length = strlen(ensembleCmd->fullSubcmdName); - copyPtr->typePtr = &ensembleCmdType; + copyPtr->typePtr = &tclEnsembleCmdType; copyPtr->internalRep.otherValuePtr = (void *) ensembleCopy; ensembleCopy->nsPtr = ensembleCmd->nsPtr; ensembleCopy->epoch = ensembleCmd->epoch; diff --git a/generic/tclObj.c b/generic/tclObj.c index 3c95c52..b50aaf0 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.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: tclObj.c,v 1.122 2007/05/11 09:43:22 dkf Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.122.2.1 2007/06/12 15:56:43 dgp Exp $ */ #include "tclInt.h" @@ -299,7 +299,8 @@ typedef struct ResolvedCmdName { Command *cmdPtr; /* A cached Command pointer. */ Namespace *refNsPtr; /* Points to the namespace containing the * reference (not the namespace that contains - * the referenced command). */ + * the referenced command). NULL if the name + * is fully qualified.*/ long refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing @@ -3460,82 +3461,52 @@ Tcl_GetCommandFromObj( * up first in the current namespace, then in * global namespace. */ { - Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; register Command *cmdPtr; - Namespace *currNsPtr; + Namespace *refNsPtr; int result; - CallFrame *savedFramePtr; - char *name; - - /* - * If the variable name is fully qualified, do as if the lookup were done - * from the global namespace; this helps avoid repeated lookups of fully - * qualified names. It costs close to nothing, and may be very helpful for - * OO applications which pass along a command name ("this"), [Patch - * 456668] - */ - - savedFramePtr = iPtr->varFramePtr; - name = Tcl_GetString(objPtr); - if ((*name++ == ':') && (*name == ':')) { - iPtr->varFramePtr = iPtr->rootFramePtr; - } /* * Get the internal representation, converting to a command type if * needed. The internal representation is a ResolvedCmdName that points to * the actual command. - */ - - if (objPtr->typePtr != &tclCmdNameType) { - result = tclCmdNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - iPtr->varFramePtr = savedFramePtr; - return (Tcl_Command) NULL; - } - } - resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; - - /* - * Get the current namespace. - */ - - currNsPtr = iPtr->varFramePtr->nsPtr; - - /* + * * Check the context namespace and the namespace epoch of the resolved - * symbol to make sure that it is fresh. If not, then force another - * conversion to the command type, to discard the old rep and create a new - * one. Note that we verify that the namespace id of the context namespace - * is the same as the one we cached; this insures that the namespace - * wasn't deleted and a new one created at the same address with the same - * command epoch. + * symbol to make sure that it is fresh. Note that we verify that the + * namespace id of the context namespace is the same as the one we cached; + * this insures that the namespace wasn't deleted and a new one created at + * the same address with the same command epoch. Note that fully qualified + * names have a NULL refNsPtr, these checks needn't be made. + * + * Check also that the command's epoch is up to date, and that the command + * is not deleted. + * + * If any check fails, then force another conversion to the command type, + * to discard the old rep and create a new one. */ - cmdPtr = NULL; - if ((resPtr != NULL) - && (resPtr->refNsPtr == currNsPtr) - && (resPtr->refNsId == currNsPtr->nsId) - && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { - cmdPtr = resPtr->cmdPtr; - if ((cmdPtr->cmdEpoch != resPtr->cmdEpoch) || (cmdPtr->flags & CMD_IS_DELETED)) { - cmdPtr = NULL; - } - } - - if (cmdPtr == NULL) { + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr != &tclCmdNameType) + || (resPtr == NULL) + || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch) + || (cmdPtr->flags & CMD_IS_DELETED) + || ((resPtr->refNsPtr != NULL) && + (((refNsPtr = (Namespace *) TclGetCurrentNamespace(interp)) + != resPtr->refNsPtr) + || (resPtr->refNsId != refNsPtr->nsId) + || (resPtr->refNsCmdEpoch != refNsPtr->cmdRefEpoch))) + ) { + result = tclCmdNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - iPtr->varFramePtr = savedFramePtr; - return (Tcl_Command) NULL; - } + resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr != NULL) { + if ((result == TCL_OK) && resPtr) { cmdPtr = resPtr->cmdPtr; + } else { + cmdPtr = NULL; } } - iPtr->varFramePtr = savedFramePtr; + return (Tcl_Command) cmdPtr; } @@ -3571,48 +3542,42 @@ TclSetCmdNameObj( Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; register Namespace *currNsPtr; - CallFrame *savedFramePtr; char *name; if (objPtr->typePtr == &tclCmdNameType) { return; } - /* - * If the variable name is fully qualified, do as if the lookup were done - * from the global namespace; this helps avoid repeated lookups of fully - * qualified names. It costs close to nothing, and may be very helpful for - * OO applications which pass along a command name ("this"), [Patch - * 456668] (Copied over from Tcl_GetCommandFromObj) - */ - - savedFramePtr = iPtr->varFramePtr; - name = Tcl_GetString(objPtr); - if ((*name++ == ':') && (*name == ':')) { - iPtr->varFramePtr = iPtr->rootFramePtr; - } - - /* - * Get the current namespace. - */ - - currNsPtr = iPtr->varFramePtr->nsPtr; - cmdPtr->refCount++; resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); resPtr->cmdPtr = cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; + name = TclGetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ + + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } + TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (void *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; - - iPtr->varFramePtr = savedFramePtr; } /* @@ -3659,7 +3624,7 @@ FreeCmdNameInternalRep( */ Command *cmdPtr = resPtr->cmdPtr; - TclCleanupCommand(cmdPtr); + TclCleanupCommandMacro(cmdPtr); ckfree((char *) resPtr); } } @@ -3735,15 +3700,6 @@ SetCmdNameFromAny( register ResolvedCmdName *resPtr; /* - * Get "objPtr"s string representation. Make it up-to-date if necessary. - */ - - name = objPtr->bytes; - if (name == NULL) { - name = Tcl_GetString(objPtr); - } - - /* * Find the Command structure, if any, that describes the command called * "name". Build a ResolvedCmdName that holds a cached pointer to this * Command, and bump the reference count in the referenced Command @@ -3751,23 +3707,35 @@ SetCmdNameFromAny( * referenced from a CmdName object. */ + name = TclGetString(objPtr); cmd = Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); + cmdPtr = (Command *) cmd; if (cmdPtr != NULL) { - /* - * Get the current namespace. - */ - - currNsPtr = iPtr->varFramePtr->nsPtr; - cmdPtr->refCount++; resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); - resPtr->cmdPtr = cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ + + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } } else { resPtr = NULL; /* no command named "name" was found */ } diff --git a/generic/tclParse.c b/generic/tclParse.c index 6974497..7add3ad 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.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: tclParse.c,v 1.52.2.1 2007/05/30 18:38:48 dgp Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.52.2.2 2007/06/12 15:56:43 dgp Exp $ */ #include "tclInt.h" @@ -460,9 +460,10 @@ Tcl_ParseCommand( * list elements. */ - while ((code == TCL_OK) && (nextElem < listEnd)) { + while (nextElem < listEnd) { code = TclFindElement(NULL, nextElem, listEnd - nextElem, &elemStart, &nextElem, NULL, NULL); + if (code != TCL_OK) break; if (elemStart < listEnd) { elemCount++; } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index a575f04..90eb032 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.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: tclTrace.c,v 1.37 2007/05/07 19:45:33 dgp Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.37.2.1 2007/06/12 15:56:44 dgp Exp $ */ #include "tclInt.h" @@ -1396,7 +1396,8 @@ int TclCheckExecutionTraces( Tcl_Interp *interp, /* The current interpreter. */ CONST char *command, /* Pointer to beginning of the current command - * string. */ + * string. If NULL, the string will be + * generated from (objc,objv) */ int numChars, /* The number of characters in 'command' which * are part of the command string. */ Command *cmdPtr, /* Points to command's Command struct. */ @@ -1412,11 +1413,24 @@ TclCheckExecutionTraces( int traceCode = TCL_OK; TraceCommandInfo* tcmdPtr; Tcl_InterpState state = NULL; + Tcl_Obj *commandPtr = NULL; - if (command == NULL || cmdPtr->tracePtr == NULL) { + if (cmdPtr->tracePtr == NULL) { return traceCode; } + /* + * Insure that we have a nul-terminated command string + */ + + if (!command) { + commandPtr = Tcl_NewListObj(objc, objv); + command = Tcl_GetStringFromObj(commandPtr, &numChars); + } else if ((numChars != -1) && (command[numChars] != '\0')) { + commandPtr = Tcl_NewStringObj(command, numChars); + command = TclGetString(commandPtr); + } + curLevel = iPtr->varFramePtr->level; active.nextPtr = iPtr->activeCmdTracePtr; @@ -1467,6 +1481,10 @@ TclCheckExecutionTraces( if (state) { (void) Tcl_RestoreInterpState(interp, state); } + + if (commandPtr) { + Tcl_DecrRefCount(commandPtr); + } return(traceCode); } @@ -1497,7 +1515,8 @@ int TclCheckInterpTraces( Tcl_Interp *interp, /* The current interpreter. */ CONST char *command, /* Pointer to beginning of the current command - * string. */ + * string. If NULL, the string will be + * generated from (objc,objv) */ int numChars, /* The number of characters in 'command' which * are part of the command string. */ Command *cmdPtr, /* Points to command's Command struct. */ @@ -1512,12 +1531,25 @@ TclCheckInterpTraces( int curLevel; int traceCode = TCL_OK; Tcl_InterpState state = NULL; + Tcl_Obj *commandPtr = NULL; - if (command == NULL || iPtr->tracePtr == NULL + if ((iPtr->tracePtr == NULL) || (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { return(traceCode); } + /* + * Insure that we have a nul-terminated command string + */ + + if (!command) { + commandPtr = Tcl_NewListObj(objc, objv); + command = Tcl_GetStringFromObj(commandPtr, &numChars); + } else if ((numChars != -1) && (command[numChars] != '\0')) { + commandPtr = Tcl_NewStringObj(command, numChars); + command = TclGetString(commandPtr); + } + curLevel = iPtr->numLevels; active.nextPtr = iPtr->activeInterpTracePtr; @@ -1615,6 +1647,10 @@ TclCheckInterpTraces( Tcl_DiscardInterpState(state); } } + + if (commandPtr) { + Tcl_DecrRefCount(commandPtr); + } return(traceCode); } diff --git a/generic/tclVar.c b/generic/tclVar.c index 53e7739..e32e866 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.135 2007/05/11 09:44:59 dkf Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.135.2.1 2007/06/12 15:56:44 dgp Exp $ */ #include "tclInt.h" @@ -4063,7 +4063,7 @@ TclDeleteNamespaceVars( if (nsPtr == iPtr->globalNsPtr) { flags = TCL_GLOBAL_ONLY; - } else if (nsPtr == (Namespace *) Tcl_GetCurrentNamespace(interp)) { + } else if (nsPtr == (Namespace *) TclGetCurrentNamespace(interp)) { flags = TCL_NAMESPACE_ONLY; } @@ -4131,7 +4131,7 @@ TclDeleteVars( int flags; ActiveVarTrace *activePtr; Tcl_Obj *objPtr; - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); /* * Determine what flags to pass to the trace callback functions. |