diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 1880 |
1 files changed, 1304 insertions, 576 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6ce696a..cf4bbe4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -11,11 +11,12 @@ * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. + * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net> * * 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.303 2008/06/13 12:14:32 das Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.304 2008/07/13 09:03:33 msofer Exp $ */ #include "tclInt.h" @@ -25,6 +26,7 @@ #include <limits.h> #include <math.h> #include "tommath.h" +#include "tclNRE.h" /* * Determine whether we're using IEEE floating point @@ -59,8 +61,8 @@ static int CancelEvalProc(ClientData clientData, static int CheckDoubleResult(Tcl_Interp *interp, double dResult); static void DeleteInterpProc(Tcl_Interp *interp); static void DeleteOpCmdClientData(ClientData clientData); -static Tcl_Obj *GetCommandSource(Interp *iPtr, const char *command, - int numChars, int objc, Tcl_Obj *const objv[]); +static Tcl_Obj *GetCommandSource(Interp *iPtr, int objc, + Tcl_Obj *const objv[], int lookup); static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int OldMathFuncProc(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *const *objv); @@ -104,6 +106,37 @@ static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, MODULE_SCOPE const TclStubs * const tclConstStubsPtr; + +/* + * Block for Tcl_EvalObjv helpers + */ + +static void TEOV_SwitchVarFrame(Tcl_Interp *interp); + +static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int flags); + +static inline Command * + TEOV_LookupCmdFromObj(Tcl_Interp *interp, Tcl_Obj *namePtr, + Namespace *lookupNsPtr); + +static int TEOV_NotFound(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], Namespace *lookupNsPtr); + +static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, + int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); + +static TclNR_PostProc TEOV_RestoreVarFrame; +static TclNR_PostProc TEOV_RunLeaveTraces; +static TclNR_PostProc TEOV_Exception; +static TclNR_PostProc TEOV_Error; +static TclNR_PostProc TEOEx_ListCallback; +static TclNR_PostProc TEOEx_ByteCodeCallback; + +static int NRPostProcess(Tcl_Interp *interp, int result, int objc, + Tcl_Obj *const objv[]); + + /* * The following structure define the commands in the Tcl core. */ @@ -112,6 +145,7 @@ typedef struct { const char *name; /* Name of object-based command. */ Tcl_ObjCmdProc *objProc; /* Object-based function for command. */ CompileProc *compileProc; /* Function called to compile command. */ + Tcl_ObjCmdProc *nreProc; /* NR-based function for command */ int isSafe; /* If non-zero, command will be present in * safe interpreter. Otherwise it will be * hidden. */ @@ -126,92 +160,92 @@ static const CmdInfo builtInCmds[] = { * Commands in the generic core. */ - {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1}, - {"apply", Tcl_ApplyObjCmd, NULL, 1}, - {"array", Tcl_ArrayObjCmd, NULL, 1}, - {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, + {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1}, + {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1}, + {"array", Tcl_ArrayObjCmd, NULL, NULL, 1}, + {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1}, #ifndef EXCLUDE_OBSOLETE_COMMANDS - {"case", Tcl_CaseObjCmd, NULL, 1}, + {"case", Tcl_CaseObjCmd, NULL, NULL, 1}, #endif - {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, 1}, - {"concat", Tcl_ConcatObjCmd, NULL, 1}, - {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, 1}, - {"error", Tcl_ErrorObjCmd, NULL, 1}, - {"eval", Tcl_EvalObjCmd, NULL, 1}, - {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, 1}, - {"for", Tcl_ForObjCmd, TclCompileForCmd, 1}, - {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, - {"format", Tcl_FormatObjCmd, NULL, 1}, - {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, 1}, - {"if", Tcl_IfObjCmd, TclCompileIfCmd, 1}, - {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, - {"join", Tcl_JoinObjCmd, NULL, 1}, - {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, 1}, - {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, 1}, - {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, 1}, - {"linsert", Tcl_LinsertObjCmd, NULL, 1}, - {"list", Tcl_ListObjCmd, TclCompileListCmd, 1}, - {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, 1}, - {"lrange", Tcl_LrangeObjCmd, NULL, 1}, - {"lrepeat", Tcl_LrepeatObjCmd, NULL, 1}, - {"lreplace", Tcl_LreplaceObjCmd, NULL, 1}, - {"lreverse", Tcl_LreverseObjCmd, NULL, 1}, - {"lsearch", Tcl_LsearchObjCmd, NULL, 1}, - {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, 1}, - {"lsort", Tcl_LsortObjCmd, NULL, 1}, - {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, 1}, - {"package", Tcl_PackageObjCmd, NULL, 1}, - {"proc", Tcl_ProcObjCmd, NULL, 1}, - {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, 1}, - {"regsub", Tcl_RegsubObjCmd, NULL, 1}, - {"rename", Tcl_RenameObjCmd, NULL, 1}, - {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, 1}, - {"scan", Tcl_ScanObjCmd, NULL, 1}, - {"set", Tcl_SetObjCmd, TclCompileSetCmd, 1}, - {"split", Tcl_SplitObjCmd, NULL, 1}, - {"subst", Tcl_SubstObjCmd, NULL, 1}, - {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, 1}, - {"trace", Tcl_TraceObjCmd, NULL, 1}, - {"unset", Tcl_UnsetObjCmd, NULL, 1}, - {"uplevel", Tcl_UplevelObjCmd, NULL, 1}, - {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, 1}, - {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, 1}, - {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, 1}, + {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, NULL, 1}, + {"concat", Tcl_ConcatObjCmd, NULL, NULL, 1}, + {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1}, + {"error", Tcl_ErrorObjCmd, NULL, NULL, 1}, + {"eval", Tcl_EvalObjCmd, NULL, NULL, 1}, + {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, NULL, 1}, + {"for", Tcl_ForObjCmd, TclCompileForCmd, NULL, 1}, + {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, NULL, 1}, + {"format", Tcl_FormatObjCmd, NULL, NULL, 1}, + {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, + {"if", Tcl_IfObjCmd, TclCompileIfCmd, NULL, 1}, + {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1}, + {"join", Tcl_JoinObjCmd, NULL, NULL, 1}, + {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, 1}, + {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, 1}, + {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, 1}, + {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, + {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, + {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, + {"lrange", Tcl_LrangeObjCmd, NULL, NULL, 1}, + {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, + {"lreplace", Tcl_LreplaceObjCmd, NULL, NULL, 1}, + {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1}, + {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, + {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, + {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, + {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, TclNRNamespaceObjCmd, 1}, + {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, + {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, + {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, + {"regsub", Tcl_RegsubObjCmd, NULL, NULL, 1}, + {"rename", Tcl_RenameObjCmd, NULL, NULL, 1}, + {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1}, + {"scan", Tcl_ScanObjCmd, NULL, NULL, 1}, + {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1}, + {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, + {"subst", Tcl_SubstObjCmd, NULL, NULL, 1}, + {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, NULL, 1}, + {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, + {"unset", Tcl_UnsetObjCmd, NULL, NULL, 1}, + {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1}, + {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, + {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, + {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, NULL, 1}, /* * Commands in the OS-interface. Note that many of these are unsafe. */ - {"after", Tcl_AfterObjCmd, NULL, 1}, - {"cd", Tcl_CdObjCmd, NULL, 0}, - {"close", Tcl_CloseObjCmd, NULL, 1}, - {"eof", Tcl_EofObjCmd, NULL, 1}, - {"encoding", Tcl_EncodingObjCmd, NULL, 0}, - {"exec", Tcl_ExecObjCmd, NULL, 0}, - {"exit", Tcl_ExitObjCmd, NULL, 0}, - {"fblocked", Tcl_FblockedObjCmd, NULL, 1}, - {"fconfigure", Tcl_FconfigureObjCmd, NULL, 0}, - {"fcopy", Tcl_FcopyObjCmd, NULL, 1}, - {"file", Tcl_FileObjCmd, NULL, 0}, - {"fileevent", Tcl_FileEventObjCmd, NULL, 1}, - {"flush", Tcl_FlushObjCmd, NULL, 1}, - {"gets", Tcl_GetsObjCmd, NULL, 1}, - {"glob", Tcl_GlobObjCmd, NULL, 0}, - {"load", Tcl_LoadObjCmd, NULL, 0}, - {"open", Tcl_OpenObjCmd, NULL, 0}, - {"pid", Tcl_PidObjCmd, NULL, 1}, - {"puts", Tcl_PutsObjCmd, NULL, 1}, - {"pwd", Tcl_PwdObjCmd, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, 1}, - {"seek", Tcl_SeekObjCmd, NULL, 1}, - {"socket", Tcl_SocketObjCmd, NULL, 0}, - {"source", Tcl_SourceObjCmd, NULL, 0}, - {"tell", Tcl_TellObjCmd, NULL, 1}, - {"time", Tcl_TimeObjCmd, NULL, 1}, - {"unload", Tcl_UnloadObjCmd, NULL, 0}, - {"update", Tcl_UpdateObjCmd, NULL, 1}, - {"vwait", Tcl_VwaitObjCmd, NULL, 1}, - {NULL, NULL, NULL, 0} + {"after", Tcl_AfterObjCmd, NULL, NULL, 1}, + {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, NULL, 1}, + {"eof", Tcl_EofObjCmd, NULL, NULL, 1}, + {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0}, + {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, + {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, + {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1}, + {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, + {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1}, + {"file", Tcl_FileObjCmd, NULL, NULL, 0}, + {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1}, + {"flush", Tcl_FlushObjCmd, NULL, NULL, 1}, + {"gets", Tcl_GetsObjCmd, NULL, NULL, 1}, + {"glob", Tcl_GlobObjCmd, NULL, NULL, 0}, + {"load", Tcl_LoadObjCmd, NULL, NULL, 0}, + {"open", Tcl_OpenObjCmd, NULL, NULL, 0}, + {"pid", Tcl_PidObjCmd, NULL, NULL, 1}, + {"puts", Tcl_PutsObjCmd, NULL, NULL, 1}, + {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, NULL, 1}, + {"seek", Tcl_SeekObjCmd, NULL, NULL, 1}, + {"socket", Tcl_SocketObjCmd, NULL, NULL, 0}, + {"source", Tcl_SourceObjCmd, NULL, NULL, 0}, + {"tell", Tcl_TellObjCmd, NULL, NULL, 1}, + {"time", Tcl_TimeObjCmd, NULL, NULL, 1}, + {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, + {"update", Tcl_UpdateObjCmd, NULL, NULL, 1}, + {"vwait", Tcl_VwaitObjCmd, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, 0} }; /* @@ -323,46 +357,6 @@ static const OpCmdInfo mathOpCmds[] = { {0}, NULL} }; -/* - * Macros for stack checks. The goal of these macros is to allow the size of - * the stack to be checked (so preventing overflow) in a *cheap* way. Note - * that the check needs to be (amortized) cheap since it is on the critical - * path for recursion. - */ - -#if defined(TCL_NO_STACK_CHECK) -/* - * Stack check disabled: make them noops. - */ - -# define CheckCStack(interp, localIntPtr) 1 -# define GetCStackParams(iPtr) /* do nothing */ -#elif defined(TCL_CROSS_COMPILE) - -/* - * This variable is static and only set *once*, during library initialization. - * It therefore needs no thread guards. - */ - -static int stackGrowsDown = 1; -# define GetCStackParams(iPtr) \ - stackGrowsDown = TclpGetCStackParams(&((iPtr)->stackBound)) -# define CheckCStack(iPtr, localIntPtr) \ - (stackGrowsDown \ - ? ((localIntPtr) > (iPtr)->stackBound) \ - : ((localIntPtr) < (iPtr)->stackBound) \ - ) -#else /* !TCL_NO_STACK_CHECK && !TCL_CROSS_COMPILE */ -# define GetCStackParams(iPtr) \ - TclpGetCStackParams(&((iPtr)->stackBound)) -# ifdef TCL_STACK_GROWS_UP -# define CheckCStack(iPtr, localIntPtr) \ - (!(iPtr)->stackBound || (localIntPtr) < (iPtr)->stackBound) -# else /* TCL_STACK_GROWS_UP */ -# define CheckCStack(iPtr, localIntPtr) \ - ((localIntPtr) > (iPtr)->stackBound) -# endif /* TCL_STACK_GROWS_UP */ -#endif /* TCL_NO_STACK_CHECK/TCL_CROSS_COMPILE */ /* * This is the script cancellation struct and hash table. The hash table @@ -695,13 +689,6 @@ Tcl_CreateInterp(void) iPtr->asyncReadyPtr = TclGetAsyncReadyPtr(); /* - * Insure that the stack checking mechanism for this interp is - * initialized. - */ - - GetCStackParams(iPtr); - - /* * Create the core commands. Do it here, rather than calling * Tcl_CreateCommand, because it's faster (there's no need to check for a * pre-existing command by the same name). If a command has a Tcl_CmdProc @@ -736,6 +723,7 @@ Tcl_CreateInterp(void) cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; + cmdPtr->nreProc = cmdInfoPtr->nreProc; Tcl_SetHashValue(hPtr, cmdPtr); } } @@ -779,6 +767,13 @@ Tcl_CreateInterp(void) Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", Tcl_DisassembleObjCmd, NULL, NULL); + /* + * Create an unsupported command for tailcalls + */ + + TclNR_CreateCommand(interp, "::tcl::unsupported::tailcall", + /*objProc*/ NULL, TclTailcallObjCmd, NULL, NULL); + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -901,6 +896,7 @@ Tcl_CreateInterp(void) Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); } + TOP_RECORD(iPtr) = NULL; return interp; } @@ -1978,6 +1974,7 @@ Tcl_CreateCommand( cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; + cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update @@ -2149,6 +2146,7 @@ Tcl_CreateObjCommand( cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; + cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update @@ -2557,8 +2555,12 @@ Tcl_SetCommandInfoFromToken( if (infoPtr->objProc == NULL) { cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = cmdPtr; + cmdPtr->nreProc = NULL; } else { - cmdPtr->objProc = infoPtr->objProc; + if (infoPtr->objProc != cmdPtr->objProc) { + cmdPtr->nreProc = NULL; + cmdPtr->objProc = infoPtr->objProc; + } cmdPtr->objClientData = infoPtr->objClientData; } cmdPtr->deleteProc = infoPtr->deleteProc; @@ -3123,7 +3125,7 @@ CancelEvalProc(clientData, interp, code) * * This function returns a Tcl_Obj with the full source string for the * command. This insures that traces get a correct NUL-terminated command - * string. + * string. The Tcl_Obj has refCount==1. * *---------------------------------------------------------------------- */ @@ -3131,18 +3133,41 @@ CancelEvalProc(clientData, interp, code) static Tcl_Obj * GetCommandSource( Interp *iPtr, - const char *command, - int numChars, int objc, - Tcl_Obj *const objv[]) + Tcl_Obj *const objv[], + int lookup) { - if (!command) { - return Tcl_NewListObj(objc, objv); - } - if (command == (char *) -1) { - command = TclGetSrcInfoForCmd(iPtr, &numChars); + Tcl_Obj *objPtr, *obj2Ptr; + CmdFrame *cfPtr = iPtr->cmdFramePtr; + const char *command = NULL; + int numChars; + + objPtr = Tcl_NewListObj(objc, objv); + if (lookup && cfPtr) { + switch (cfPtr->type) { + case TCL_LOCATION_EVAL: + case TCL_LOCATION_SOURCE: + command = cfPtr->cmd.str.cmd; + numChars = cfPtr->cmd.str.len; + break; + case TCL_LOCATION_BC: + case TCL_LOCATION_PREBC: + command = TclGetSrcInfoForCmd(iPtr, &numChars); + break; + case TCL_LOCATION_EVAL_LIST: + /* Got it already */ + break; + } + if (command) { + obj2Ptr = Tcl_NewStringObj(command, numChars); + objPtr->bytes = obj2Ptr->bytes; + objPtr->length = numChars; + obj2Ptr->bytes = NULL; + Tcl_DecrRefCount(obj2Ptr); + } } - return Tcl_NewStringObj(command, numChars); + Tcl_IncrRefCount(objPtr); + return objPtr; } /* @@ -3294,8 +3319,7 @@ OldMathFuncProc( * We have a non-numeric argument. */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument to math function didn't have numeric value",-1)); + Tcl_SetResult(interp, "argument to math function didn't have numeric value", TCL_STATIC); TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); ckfree((char *)args); return TCL_ERROR; @@ -3571,7 +3595,6 @@ int TclInterpReady( Tcl_Interp *interp) { - int localInt; /* used for checking the stack */ register Interp *iPtr = (Interp *) interp; /* @@ -3599,18 +3622,12 @@ TclInterpReady( * probably because of an infinite loop somewhere. */ - if (((iPtr->numLevels) <= iPtr->maxNestingDepth) - && CheckCStack(iPtr, &localInt)) { + if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) { return TCL_OK; } - if (!CheckCStack(iPtr, &localInt)) { - Tcl_AppendResult(interp, - "out of stack space (infinite loop?)", NULL); - } else { - Tcl_AppendResult(interp, - "too many nested evaluations (infinite loop?)", NULL); - } + Tcl_AppendResult(interp, + "too many nested evaluations (infinite loop?)", NULL); return TCL_ERROR; } @@ -3871,20 +3888,14 @@ Tcl_CancelEval( /* *---------------------------------------------------------------------- * - * TclEvalObjvInternal + * Tcl_EvalObjv -- * * This function evaluates 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 bytecode - * engine also calls it directly. + * 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. If an - * error occurs, this function does NOT add any information to the - * errorInfo variable. + * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: * Depends on the command. @@ -3893,96 +3904,78 @@ Tcl_CancelEval( */ int -TclEvalObjvInternal( +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. */ - 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), -1 if it - * is to be generated from bytecode - * source. This is only needed the traces. */ - 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. */ + * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and + * TCL_EVAL_NOERR are currently supported. */ { Command *cmdPtr; Interp *iPtr = (Interp *) interp; - Tcl_Obj **newObjv; - int i; - CallFrame *savedVarFramePtr = NULL; - CallFrame *varFramePtr = iPtr->varFramePtr; - int code = TCL_OK; - int traceCode = TCL_OK; - int checkTraces = 1, traced; - Namespace *savedNsPtr = NULL; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Tcl_Obj *commandPtr = NULL; + int result; + Namespace *lookupNsPtr; - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } + TEOV_record *rootPtr = TOP_RECORD(iPtr); + TEOV_record *recordPtr; + + Tcl_ObjCmdProc *objProc; + ClientData objClientData; + int tebcCall = TEBC_CALL(iPtr); - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - return TCL_ERROR; + TEBC_CALL(iPtr) = 0; + + restartAtTop: + iPtr->numLevels++; + result = TclInterpReady(interp); + + if (result == TCL_OK) { + result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); } - if (objc == 0) { - return TCL_OK; + if ((result != TCL_OK) || (objc == 0)) { + iPtr->lookupNsPtr = NULL; + iPtr->numLevels--; + goto done; } /* - * If any execution traces rename or delete the current command, we may - * need (at most) two passes here. + * Always push a record for the command (avoid queuing callbacks for an + * older command!) */ - reparseBecauseOfTraces: - + PUSH_RECORD(interp, recordPtr); + /* - * Configure evaluation context to match the requested flags. + * Push records for task to be done on return, in INVERSE order. First, if + * needed, the exception handlers (as they should happen last). */ - - 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; - } + + if (!(flags & TCL_EVAL_NOERR)) { + TEOV_PushExceptionHandlers(interp, objc, objv, flags); } /* - * Find the function to execute this command. If there isn't one, then see - * if there is an unknown command handler registered for this namespace. - * If so, create a new word array with the handler as the first words and - * the original command words as arguments. Then call ourselves - * recursively to execute it. + * Configure evaluation context to match the requested flags. */ - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (!cmdPtr) { - goto notFound; - } + lookupNsPtr = iPtr->lookupNsPtr; + if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { + if (!lookupNsPtr) { + lookupNsPtr = iPtr->globalNsPtr; + } else { + iPtr->lookupNsPtr = NULL; + } + } else { + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } - if (savedNsPtr) { - varFramePtr->nsPtr = savedNsPtr; - } else if (iPtr->ensembleRewrite.sourceObjs) { /* * TCL_EVAL_INVOKE was not set: clear rewrite rules */ @@ -3990,57 +3983,38 @@ TclEvalObjvInternal( iPtr->ensembleRewrite.sourceObjs = NULL; } + /* - * Call trace functions if needed. + * Lookup the command */ + + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + notFound: + result = TEOV_NotFound(interp, objc, objv, lookupNsPtr); + iPtr->numLevels--; + goto done; + } - traced = (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)); - if (traced && checkTraces) { - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - - /* - * Insure that we have a correct nul-terminated command string for the - * trace code. - */ - - commandPtr = GetCommandSource(iPtr, command, length, objc, objv); - command = TclGetStringFromObj(commandPtr, &length); - + if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { /* - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the - * traces so that the structure doesn't go away underneath our feet. + * Call enter traces. They will schedule a call to the leave traces if + * necessary. */ - cmdPtr->refCount++; - if (iPtr->tracePtr && (traceCode == TCL_OK)) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr); + if (!cmdPtr) { + goto notFound; } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - TclCleanupCommandMacro(cmdPtr); - - /* - * If the traces modified/deleted the command or any existing traces, - * they will update the command's epoch. When that happens, set - * checkTraces is set to 0 to prevent the re-calling of traces (and - * any possible infinite loop) and we go back to re-find the command - * implementation. - */ - - if (cmdEpoch != newEpoch) { - checkTraces = 0; - if (commandPtr) { - Tcl_DecrRefCount(commandPtr); - } - goto reparseBecauseOfTraces; + if (result != TCL_OK) { + iPtr->numLevels--; + goto done; } } + + /* + * Found a command! The real work begins now ... + */ if (TCL_DTRACE_CMD_ARGS_ENABLED()) { char *a[10]; @@ -4063,260 +4037,608 @@ TclEvalObjvInternal( /* * Finally, invoke the command's Tcl_ObjCmdProc. + * + * Do the NR dance right here: + * - for non-NR enabled commands, just sigh and call the objProc + * - for NR-enabled commands call the part1, decide what to do with + * the continuation: + * . if it is a bytecode AND we were called by TEBC, pass it + * back. Otherwise just call a new TEBC on it. Don't register + * the callback, TEBC handles those. + * . if it is a command and it has a callback, push the callback + * into the TODO list, set the params as needed and restart at + * the top. + * + * Note that I removed the DTRACE thing: I have not really thought + * about where it really belongs, and do not really know what it does + * either. */ - cmdPtr->refCount++; iPtr->cmdCount++; - if (code == TCL_OK && traceCode == TCL_OK - && !TclLimitExceeded(iPtr->limit)) { - if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } - code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); - if (TCL_DTRACE_CMD_RETURN_ENABLED()) { - TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), code); - } + if (TclLimitExceeded(iPtr->limit)) { + result = TCL_ERROR; + iPtr->numLevels--; + goto done; } - if (TclAsyncReady(iPtr)) { - code = Tcl_AsyncInvoke(interp, code); - } - if (code == TCL_OK && Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - code = TCL_ERROR; - } - if (code == TCL_OK && TclLimitReady(iPtr->limit)) { - code = Tcl_LimitCheck(interp); + objProc = cmdPtr->nreProc; + if (!objProc) { + objProc = cmdPtr->objProc; } - + objClientData = cmdPtr->objClientData; + + COMPLETE_RECORD(recordPtr); + cmdPtr->refCount++; + + objProcReentryPoint: /* - * Call 'leave' command traces + * If this is an NR-enabled command, find the real objProc. */ - if (traced) { - 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); + result = (*objProc)(objClientData, interp, objc, objv); + if ((result != TCL_OK) || !VALID_NEW_REQUEST(recordPtr)) { +#if 0 + TclStackPurge(interp, recordPtr->tosPtr); +#endif + goto done; + } + + /* + * We got a valid callback request: let us complete the corresponding + * record and proceed with the next call. + */ + + switch(recordPtr->type) { + case TCL_NR_NO_TYPE: { + break; + } + case TCL_NR_BC_TYPE: { + tcl_nr_bc_type: + if (USE_NR_TEBC && tebcCall) { + /* + * We were called by TEBC, and we need a bytecode to be + * executed: just ask our caller to do that. + * TEBC_CALL(iPtr) = TEBC_DO_EXEC = 0 is not really needed, as + * it is already 0==TEBC_DO_EXEC + */ + + TEBC_CALL(iPtr) = TEBC_DO_EXEC; + TEBC_DATA(iPtr) = recordPtr->data.codePtr; + return TCL_OK; } - if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + + /* + * No TEBC atop - we'll just have to instantiate a new one and + * do the callback on return. + */ + + result = TclExecuteByteCode(interp, recordPtr->data.codePtr); + goto done; + } + case TCL_NR_TAILCALL_TYPE: { + /* + * Got to save this record, free the stack (ie, perform all + * pending callbacks) and restore the record. + */ + + Tcl_Obj *tailObjPtr = recordPtr->data.obj.objPtr; + + result = TclEvalObjv_NR2(interp, result, rootPtr); + + if (result != TCL_OK) { + goto done; } + if (USE_NR_TEBC && tebcCall) { + /* + * We were called by TEBC, and we need it to drop a frame: let + * him know. + */ + + TEBC_CALL(iPtr) = TEBC_DO_TAILCALL; + TEBC_DATA(iPtr) = tailObjPtr; + return TCL_OK; + } + + /* + * ONLY supported if called from TEBC. Could do an 'uplevel 1'? + * Run from here (as hinted below)? Mmhhh ... FIXME. Maybe + * tailcalls SHOULD actually be bytecompiled (we know how to more + * or less fake it when falling off TEBC)? + */ + + Tcl_Panic("tailcall called from a non-compiled command?"); + /* FALL THROUGH */ } + case TCL_NR_CMD_TYPE: { + /* + * We got an unshared canonical list to eval , do it from here. + */ - /* - * 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. - */ + Tcl_Obj *objPtr = recordPtr->data.obj.objPtr; + Tcl_Obj **elemPtr; - if (traceCode != TCL_OK) { - code = traceCode; + flags = recordPtr->data.obj.flags; + Tcl_ListObjGetElements(NULL, objPtr, &objc, &elemPtr); + objv = elemPtr; + if (objc == 0) { + goto done; + } + goto restartAtTop; + } + case TCL_NR_SCRIPT_TYPE: { + Tcl_Obj *objPtr = recordPtr->data.obj.objPtr; + + flags = recordPtr->data.obj.flags; + if (USE_NR_TEBC && tebcCall) { + result = TclNREvalObjEx(interp, objPtr, flags, NULL, 0); + if (result == TCL_OK) { + switch (recordPtr->type) { + case TCL_NR_BC_TYPE: + goto tcl_nr_bc_type; + case TCL_NR_NO_TYPE: + goto done; + default: + Tcl_Panic("TEOEx called from TEOV returns unexpected record type"); + } + } + goto done; + } else { + result = TclEvalObjEx(interp, objPtr, flags, NULL, 0); + goto done; + } } - if (commandPtr) { - Tcl_DecrRefCount(commandPtr); + case TCL_NR_OBJPROC_TYPE: { + /* This is a rewrite like ns-import does, without a new + * cmdPtr or new reentrant call. FIXME: add the possibility of a + * new callback (TclNR_ObjProc has that), and maybe also edition + * of objc/objv? */ + + objProc = recordPtr->data.objProc.objProc; + objClientData = recordPtr->data.objProc.clientData; + recordPtr->type = TCL_NR_NO_TYPE; + goto objProcReentryPoint; + } + default: { + Tcl_Panic("TEOV: unknown NR-request type %i!", recordPtr->type); } } + done: + return TclEvalObjv_NR2(interp, result, rootPtr); +} - /* - * Decrement the reference count of cmdPtr and deallocate it if it has - * dropped to zero. - */ - - TclCleanupCommandMacro(cmdPtr); +int TclEvalObjv_NR2( + Tcl_Interp *interp, + int result, + struct TEOV_record *rootPtr) +{ + Interp *iPtr = (Interp *) interp; + TEOV_record *recordPtr; /* * 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. + * + * This only needs to be done for the first item in the list: all other + * are for NR function calls, and those are Tcl_Obj based. */ if (*(iPtr->result) != 0) { (void) Tcl_GetObjResult(interp); } - if (TCL_DTRACE_CMD_RESULT_ENABLED()) { - Tcl_Obj *r; + TclResetCancellation(interp, 0); - r = Tcl_GetObjResult(interp); - TCL_DTRACE_CMD_RESULT(TclGetString(objv[0]), code, TclGetString(r),r); - } + while (TOP_RECORD(iPtr) != rootPtr) { + POP_RECORD(iPtr, recordPtr); - done: - if (savedVarFramePtr) { - iPtr->varFramePtr = savedVarFramePtr; - } - return code; + while (recordPtr->callbackPtr) {// + TEOV_callback *callbackPtr = recordPtr->callbackPtr; + result = (*callbackPtr->procPtr)(&callbackPtr->data0, + interp, result); + callbackPtr = callbackPtr->nextPtr; + TclSmallFree(recordPtr->callbackPtr); + recordPtr->callbackPtr = callbackPtr; + } - notFound: - { - Namespace *currNsPtr = NULL; /* Used to check for and invoke any - * registered unknown command handler - * for the current namespace (TIP - * 181). */ - int newObjc, handlerObjc; - Tcl_Obj **handlerObjv; - - currNsPtr = varFramePtr->nsPtr; - if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { - currNsPtr = iPtr->globalNsPtr; - if (currNsPtr == NULL) { - Tcl_Panic("TclEvalObjvInternal: NULL global namespace pointer"); - } + if (!CHECK_EXTRA(iPtr, recordPtr)) { + Tcl_Panic("TclEvalObjv_NR2: wrong tosPtr?"); + /* TclStackPurge(interp, recordPtr->tosPtr); */ } /* - * Check to see if the resolution namespace has lost its unknown - * handler. If so, reset it to "::unknown". + * Decrement the reference count of cmdPtr and deallocate it if it has + * dropped to zero. The level only needs fixing for records that + * pushed a cmdPtr. */ - if (currNsPtr->unknownHandlerPtr == NULL) { - TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); - Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); + if (recordPtr->cmdPtr) { + TclCleanupCommandMacro(recordPtr->cmdPtr); + iPtr->numLevels--; } - /* - * Get the list of words for the unknown handler and allocate enough - * space to hold both the handler prefix and all words of the command - * invokation itself. - */ + if (TCL_DTRACE_CMD_RETURN_ENABLED()) { + TCL_DTRACE_CMD_RETURN(TclGetString(objv[0]), result); + } + + FREE_RECORD(iPtr, recordPtr); + } + + /* + * Do not interrupt a series of cleanups with async or limit checks: just + * check at the end. + */ + + if (TclAsyncReady(iPtr)) { + result = Tcl_AsyncInvoke(interp, result); + } + + if (result == TCL_OK) { + result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); + } + + if (result == TCL_OK && TclLimitReady(iPtr->limit)) { + result = Tcl_LimitCheck(interp); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TEOV_Exception - + * TEOV_LookupCmdFromObj - + * TEOV_RunEnterTraces - + * TEOV_RunLeaveTraces - + * TEOV_NotFound - + * + * These are helper functions for Tcl_EvalObjv. + * + *---------------------------------------------------------------------- + */ - Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, - &handlerObjc, &handlerObjv); - newObjc = objc + handlerObjc; - newObjv = (Tcl_Obj **) TclStackAlloc(interp, - (int) sizeof(Tcl_Obj *) * newObjc); +static void +TEOV_PushExceptionHandlers( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[], + int flags) +{ + Interp *iPtr = (Interp *) interp; + + /* + * If any error processing is necessary, push the appropriate + * records. Note that we have to push them in the inverse order: first + * the one that has to run last. + */ + if (!(flags & TCL_EVAL_INVOKE)) { /* - * Copy command prefix from unknown handler and add on the real - * command's full argument list. Note that we only use memcpy() once - * because we have to increment the reference count of all the handler - * arguments anyway. + * Error messages */ + + TclNR_AddCallback(interp, TEOV_Error, INT2PTR(objc), (ClientData) objv, + NULL, NULL); + } + + if (iPtr->numLevels == 1) { + /* + * No CONTINUE or BREAK at level 0, manage RETURN + */ + + TclNR_AddCallback(interp, TEOV_Exception, NULL, NULL, NULL, NULL); + } +} - for (i = 0; i < handlerObjc; ++i) { - newObjv[i] = handlerObjv[i]; - Tcl_IncrRefCount(newObjv[i]); +static void +TEOV_SwitchVarFrame( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + /* + * Change the varFrame to be the rootVarFrame, and push a record + * to restore things at the end. + */ + + TclNR_AddCallback(interp, TEOV_RestoreVarFrame, iPtr->varFramePtr, NULL, NULL, NULL); + iPtr->varFramePtr = iPtr->rootFramePtr; +} + +static int +TEOV_RestoreVarFrame( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ((Interp *) interp)->varFramePtr = data[0]; + return result; +} + +static int +TEOV_Exception( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + + if (result != TCL_OK) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_ERROR) && !allowExceptions) { + ProcessUnexpectedResult(interp, result); + result = TCL_ERROR; } - memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); + } + return result; +} +static int +TEOV_Error( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *listPtr; + char *cmdString; + int cmdLen; + int objc = PTR2INT(data[0]); + Tcl_Obj **objv = data[1]; + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){ /* - * Look up and invoke the handler (by recursive call to this - * function). If there is no handler at all, instead of doing the - * recursive call we just generate a generic error message; it would - * be an infinite-recursion nightmare otherwise. + * If there was an error, a command string will be needed for the + * error log: get it out of the itemPtr. The details depend on the + * type */ - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); - if (cmdPtr == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[0]), "\"", NULL); - code = TCL_ERROR; - } else { - TclResetCancellation(interp, 0); + listPtr = Tcl_NewListObj(objc, objv); + cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + Tcl_DecrRefCount(listPtr); + } + iPtr->flags &= ~ERR_ALREADY_LOGGED; + return result; +} - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, newObjc, newObjv, command, - length, 0); - iPtr->numLevels--; +static int +TEOV_NotFound( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[], + Namespace *lookupNsPtr) +{ + Command * cmdPtr; + Interp *iPtr = (Interp *) interp; + Tcl_Obj **newObjv; + int i; + CallFrame *varFramePtr = iPtr->varFramePtr; + int result = TCL_OK; + Namespace *currNsPtr = NULL; /* Used to check for and invoke any + * registered unknown command handler + * for the current namespace (TIP + * 181). */ + int newObjc, handlerObjc; + Tcl_Obj **handlerObjv; + Namespace *savedNsPtr = NULL; + + currNsPtr = varFramePtr->nsPtr; + if ((currNsPtr == NULL) || (currNsPtr->unknownHandlerPtr == NULL)) { + currNsPtr = iPtr->globalNsPtr; + if (currNsPtr == NULL) { + Tcl_Panic("Tcl_EvalObjv: NULL global namespace pointer"); } + } - /* - * Release any resources we locked and allocated during the handler - * call. - */ + /* + * Check to see if the resolution namespace has lost its unknown + * handler. If so, reset it to "::unknown". + */ - for (i = 0; i < handlerObjc; ++i) { - Tcl_DecrRefCount(newObjv[i]); + if (currNsPtr->unknownHandlerPtr == NULL) { + TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); + } + + /* + * Get the list of words for the unknown handler and allocate enough + * space to hold both the handler prefix and all words of the command + * invokation itself. + */ + + Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, + &handlerObjc, &handlerObjv); + newObjc = objc + handlerObjc; + newObjv = (Tcl_Obj **) TclStackAlloc(interp, + (int) sizeof(Tcl_Obj *) * newObjc); + + /* + * Copy command prefix from unknown handler and add on the real + * command's full argument list. Note that we only use memcpy() once + * because we have to increment the reference count of all the handler + * arguments anyway. + */ + + for (i = 0; i < handlerObjc; ++i) { + newObjv[i] = handlerObjv[i]; + Tcl_IncrRefCount(newObjv[i]); + } + memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); + + /* + * Look up and invoke the handler (by recursive call to this + * function). If there is no handler at all, instead of doing the + * recursive call we just generate a generic error message; it would + * be an infinite-recursion nightmare otherwise. + * + * In this case we worry a bit less about recursion for now, and call + * the "blocking" interface. + */ + + cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr); + if (cmdPtr == NULL) { + Tcl_AppendResult(interp, "invalid command name \"", + TclGetString(objv[0]), "\"", NULL); + result = TCL_ERROR; + } else { + if (lookupNsPtr) { + savedNsPtr = varFramePtr->nsPtr; + varFramePtr->nsPtr = lookupNsPtr; } - TclStackFree(interp, newObjv); + result = Tcl_EvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR); if (savedNsPtr) { varFramePtr->nsPtr = savedNsPtr; } - goto done; } + + /* + * Release any resources we locked and allocated during the handler + * call. + */ + + for (i = 0; i < handlerObjc; ++i) { + Tcl_DecrRefCount(newObjv[i]); + } + TclStackFree(interp, newObjv); + return result; } - -/* - *---------------------------------------------------------------------- - * - * 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. */ +static int +TEOV_RunEnterTraces( + Tcl_Interp *interp, + Command **cmdPtrPtr, + int objc, + Tcl_Obj *const objv[], + Namespace *lookupNsPtr) { Interp *iPtr = (Interp *) interp; - int code = TCL_OK; - - TclResetCancellation(interp, 0); - - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objc, objv, NULL, 0, flags); - iPtr->numLevels--; - - if (code == TCL_OK) { - return code; - } else { - int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + Command *cmdPtr = *cmdPtrPtr; + int traceCode = TCL_OK; + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + char *command; + int length; + Tcl_Obj *commandPtr; + + commandPtr = GetCommandSource(iPtr, objc, objv, 1); + command = Tcl_GetStringFromObj(commandPtr, &length); + + /* + * Call trace functions + * Execute any command or execution traces. Note that we bump up the + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. + */ + + cmdPtr->refCount++; + if (iPtr->tracePtr) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + TclCleanupCommandMacro(cmdPtr); + + /* + * If the traces modified/deleted the command or any existing traces, + * they will update the command's epoch. We need to lookup again, but do + * not run enter traces on the newly found cmdPtr. + */ + + if (cmdEpoch != newEpoch) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + *cmdPtrPtr = cmdPtr; + } + if (cmdPtr) { /* - * If we are again at the top level, process any unusual return code - * returned by the evaluated code. + * Command was found: push a record to schedule + * the leave traces. */ + + TclNR_AddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), + commandPtr, cmdPtr, NULL); + cmdPtr->refCount++; + } else { + Tcl_DecrRefCount(commandPtr); + } + return traceCode; +} - if (iPtr->numLevels == 0) { - if (code == TCL_RETURN) { - code = TclUpdateReturnInfo(iPtr); - } - if ((code != TCL_ERROR) && !allowExceptions) { - ProcessUnexpectedResult(interp, code); - code = TCL_ERROR; - } +static int +TEOV_RunLeaveTraces( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + + TclResetCancellation(interp, 0); + char *command; + int length, objc; + Tcl_Obj **objv; + int traceCode = PTR2INT(data[0]); + Tcl_Obj *commandPtr = data[1]; + Command *cmdPtr = data[2]; + + command = Tcl_GetStringFromObj(commandPtr, &length); + if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) { + Tcl_Panic("Who messed with commandPtr?"); + } + + if (!(cmdPtr->flags & CMD_IS_DELETED)) { + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } + } + Tcl_DecrRefCount(commandPtr); - 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. Do not worry too much about doing - * it expensively. - */ + /* + * As cmdPtr is set, TclEvalObjv_NR2 is about to reduce the + * numlevels. Prevent that by resetting the cmdPtr field and dealing right + * here with cmdPtr->refCount. + */ - Tcl_Obj *listPtr; - char *cmdString; - int cmdLen; + TclCleanupCommandMacro(cmdPtr); - listPtr = Tcl_NewListObj(objc, objv); - cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); - Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); - Tcl_DecrRefCount(listPtr); - } + if (traceCode != TCL_OK) { + return traceCode; + } else { + return result; + } +} - return code; +static inline Command * +TEOV_LookupCmdFromObj( + Tcl_Interp *interp, + Tcl_Obj *namePtr, + Namespace *lookupNsPtr) +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr; + Namespace *savedNsPtr = iPtr->varFramePtr->nsPtr; + + if (lookupNsPtr) { + iPtr->varFramePtr->nsPtr = lookupNsPtr; + iPtr->lookupNsPtr = NULL; } + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); + iPtr->varFramePtr->nsPtr = savedNsPtr; + return cmdPtr; } /* @@ -4729,10 +5051,7 @@ TclEvalEx( TclResetCancellation(interp, 0); - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objectsUsed, objv, - parsePtr->commandStart, parsePtr->commandSize, 0); - iPtr->numLevels--; + code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR); iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; eeFramePtr->line = NULL; @@ -5004,12 +5323,36 @@ TclEvalObjEx( const CmdFrame *invoker, /* Frame of the command doing the eval. */ int word) /* Index of the word which is in objPtr. */ { + int result = TCL_OK; + TEOV_record *recordPtr; + + /* + * Push an empty record. If this is an NR call, it will modify it + * accordingly. + */ + + PUSH_RECORD(interp, recordPtr); + result = TclNREvalObjEx(interp, objPtr, flags, invoker, word); + assert((TOP_RECORD(interp) == recordPtr)); + return NRPostProcess(interp, result, 0, NULL); +} + +int +TclNREvalObjEx( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * a previous call to Tcl_CreateInterp). */ + register Tcl_Obj *objPtr, /* Pointer to object containing commands to + * execute. */ + int flags, /* Collection of OR-ed bits that control the + * evaluation of the script. Supported values + * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ + const CmdFrame *invoker, /* Frame of the command doing the eval. */ + int word) /* Index of the word which is in objPtr. */ +{ register Interp *iPtr = (Interp *) interp; char *script; int numSrcBytes; int result; - CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case - * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); Tcl_IncrRefCount(objPtr); @@ -5056,7 +5399,6 @@ TclEvalObjEx( ckalloc(eoFramePtr->nline * sizeof(int)); eoFramePtr->cmd.listPtr = objPtr; - Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); eoFramePtr->data.eval.path = NULL; /* @@ -5072,155 +5414,201 @@ TclEvalObjEx( } iPtr->cmdFramePtr = eoFramePtr; - result = Tcl_EvalObjv(interp, eoFramePtr->nline, elements, - flags); - - Tcl_DecrRefCount(copyPtr); - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; - Tcl_DecrRefCount(eoFramePtr->cmd.listPtr); - ckfree((char *) eoFramePtr->line); - eoFramePtr->line = NULL; - eoFramePtr->nline = 0; - TclStackFree(interp, eoFramePtr); - - goto done; + + TclNR_AddCallback(interp, TEOEx_ListCallback, objPtr, eoFramePtr, + copyPtr, NULL); + return TclNR_EvalObj(interp, objPtr, flags); } } - if (flags & TCL_EVAL_DIRECT) { + if (!(flags & TCL_EVAL_DIRECT)) { /* - * We're not supposed to use the compiler or byte-code interpreter. - * Let Tcl_EvalEx evaluate the command directly (and probably more - * slowly). - * - * TIP #280. Propagate context as much as we can. Especially if the - * script to evaluate is a single literal it makes sense to look if - * our context is one with absolute line numbers we can then track - * into the literal itself too. + * Let the compiler/engine subsystem do the evaluation. * - * See also tclCompile.c, TclInitCompileEnv, for the equivalent code - * in the bytecode compiler. + * TIP #280 The invoker provides us with the context for the script. + * We transfer this to the byte code compiler. */ - if (invoker == NULL) { + ByteCode *newCodePtr; + CallFrame *savedVarFramePtr = NULL; + /* Saves old copy of iPtr->varFramePtr in + * case TCL_EVAL_GLOBAL was set. */ + + if (flags & TCL_EVAL_GLOBAL) { + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = iPtr->rootFramePtr; + } + TclNR_AddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr, + objPtr, INT2PTR(allowExceptions), NULL); + + newCodePtr = TclCompileObj(interp, objPtr, invoker, word); + if (newCodePtr) { + TEOV_record *recordPtr = TOP_RECORD(interp); + + recordPtr->type = TCL_NR_BC_TYPE; + recordPtr->data.codePtr = newCodePtr; + return TCL_OK; + } else { + return TCL_ERROR; + } + } + + /* + * We're not supposed to use the compiler or byte-code interpreter. + * Let Tcl_EvalEx evaluate the command directly (and probably more + * slowly). + * + * TIP #280. Propagate context as much as we can. Especially if the + * script to evaluate is a single literal it makes sense to look if + * our context is one with absolute line numbers we can then track + * into the literal itself too. + * + * See also tclCompile.c, TclInitCompileEnv, for the equivalent code + * in the bytecode compiler. + */ + + if (invoker == NULL) { + /* + * No context, force opening of our own. + */ + + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + } else { + /* + * We have an invoker, describing the command asking for the + * evaluation of a subordinate script. This script may originate + * in a literal word, or from a variable, etc. Using the line + * array we now check if we have good line information for the + * relevant word. The type of context is relevant as well. In a + * non-'source' context we don't have to try tracking lines. + * + * First see if the word exists and is a literal. If not we go + * through the easy dynamic branch. No need to perform more + * complex invokations. + */ + + if ((invoker->nline <= word) || (invoker->line[word] < 0)) { /* - * No context, force opening of our own. + * Dynamic script, or dynamic context, force our own + * context. */ - + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + } else { /* - * We have an invoker, describing the command asking for the - * evaluation of a subordinate script. This script may originate - * in a literal word, or from a variable, etc. Using the line - * array we now check if we have good line information for the - * relevant word. The type of context is relevant as well. In a - * non-'source' context we don't have to try tracking lines. - * - * First see if the word exists and is a literal. If not we go - * through the easy dynamic branch. No need to perform more - * complex invokations. + * Try to get an absolute context for the evaluation. */ - - if ((invoker->nline <= word) || (invoker->line[word] < 0)) { + + int pc = 0; + CmdFrame *ctxPtr = (CmdFrame *) + TclStackAlloc(interp, sizeof(CmdFrame)); + + *ctxPtr = *invoker; + if (invoker->type == TCL_LOCATION_BC) { /* - * Dynamic script, or dynamic context, force our own - * context. + * Note: Type BC => ctxPtr->data.eval.path is not used. + * ctxPtr->data.tebc.codePtr is used instead. */ - - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - - } else { + + TclGetSrcInfoForPc(ctxPtr); + pc = 1; + } + + if (ctxPtr->type == TCL_LOCATION_SOURCE) { /* - * Try to get an absolute context for the evaluation. + * Absolute context to reuse. */ - - int pc = 0; - CmdFrame *ctxPtr = (CmdFrame *) - TclStackAlloc(interp, sizeof(CmdFrame)); - - *ctxPtr = *invoker; - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctxPtr->data.eval.path is not used. - * ctxPtr->data.tebc.codePtr is used instead. - */ - - TclGetSrcInfoForPc(ctxPtr); - pc = 1; - } - - if (ctxPtr->type == TCL_LOCATION_SOURCE) { - /* - * Absolute context to reuse. - */ - - iPtr->invokeCmdFramePtr = ctxPtr; - iPtr->evalFlags |= TCL_EVAL_CTX; - - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = TclEvalEx(interp, script, numSrcBytes, flags, - ctxPtr->line[word]); - - if (pc) { - /* - * Death of SrcInfo reference. - */ - - Tcl_DecrRefCount(ctxPtr->data.eval.path); - } - } else { + + iPtr->invokeCmdFramePtr = ctxPtr; + iPtr->evalFlags |= TCL_EVAL_CTX; + + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = TclEvalEx(interp, script, numSrcBytes, flags, + ctxPtr->line[word]); + + if (pc) { /* - * Dynamic context or script, easier to make our own as - * well. + * Death of SrcInfo reference. */ - - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + + Tcl_DecrRefCount(ctxPtr->data.eval.path); } - - TclStackFree(interp, ctxPtr); + } else { + /* + * Dynamic context or script, easier to make our own as + * well. + */ + + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); } + + TclStackFree(interp, ctxPtr); } - } else { - /* - * Let the compiler/engine subsystem do the evaluation. - * - * TIP #280 The invoker provides us with the context for the script. - * We transfer this to the byte code compiler. - */ + } + TclDecrRefCount(objPtr); + return result; +} - savedVarFramePtr = iPtr->varFramePtr; - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = iPtr->rootFramePtr; +static int +TEOEx_ByteCodeCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *savedVarFramePtr = data[0]; + Tcl_Obj *objPtr = data[1]; + int allowExceptions = PTR2INT(data[2]); + char *script; + int numSrcBytes; + + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); } - - result = TclCompEvalObj(interp, objPtr, invoker, word); - - /* - * If we are again at the top level, process any unusual return code - * returned by the evaluated code. - */ - - if (iPtr->numLevels == 0) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } - if ((result != TCL_OK) && (result != TCL_ERROR) - && !allowExceptions) { - ProcessUnexpectedResult(interp, result); - result = TCL_ERROR; - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - Tcl_LogCommandInfo(interp, script, script, numSrcBytes); - } + if ((result != TCL_OK) && (result != TCL_ERROR) + && !allowExceptions) { + ProcessUnexpectedResult(interp, result); + result = TCL_ERROR; + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } - iPtr->evalFlags = 0; + } + iPtr->evalFlags = 0; + + /* Restore the callFrame if this was a TCL_EVAL_GLOBAL */ + + if (savedVarFramePtr) { iPtr->varFramePtr = savedVarFramePtr; } + + TclDecrRefCount(objPtr); + return result; +} - done: +static int +TEOEx_ListCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *objPtr = data[0]; + CmdFrame *eoFramePtr = data[1]; + Tcl_Obj *copyPtr = data[2]; + + /* Remove the cmdFrame if it was added */ + Tcl_DecrRefCount(copyPtr); + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + ckfree((char *) eoFramePtr->line); + eoFramePtr->line = NULL; + eoFramePtr->nline = 0; + TclStackFree(interp, eoFramePtr); + TclDecrRefCount(objPtr); return result; } @@ -6230,8 +6618,7 @@ ExprIsqrtFunc( return TCL_OK; negarg: - Tcl_SetObjResult(interp, - Tcl_NewStringObj("square root of negative argument", -1)); + Tcl_SetResult(interp, "square root of negative argument", TCL_STATIC); return TCL_ERROR; } @@ -6991,6 +7378,347 @@ TclDTraceInfo( #endif /* USE_DTRACE */ /* + *---------------------------------------------------------------------- + * + * TclNR_CallObjProc -- + * + * This function calls an objProc directly while managing things properly + * if it happens to be an NR objProc. It is meant to be used by extenders + * that provide an NR implementation of a command, as this function + * permits a trivial coding of the non-NR objProc. + * + * 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 objProc. + * + *---------------------------------------------------------------------- + */ + +int +TclNR_CallObjProc( + Tcl_Interp *interp, + Tcl_ObjCmdProc *objProc, + ClientData clientData, + int objc, + Tcl_Obj *const objv[]) +{ + int result = TCL_OK; + TEOV_record *recordPtr; + + /* + * Push an empty record. If this is an NR call, it will modify it + * accordingly. + */ + + PUSH_RECORD(interp, recordPtr); + result = (*objProc)(clientData, interp, objc, objv); + return NRPostProcess(interp, result, objc, objv); +} + +static int +NRPostProcess( + Tcl_Interp *interp, + int result, + int objc, + Tcl_Obj *const objv[]) +{ + TEOV_record *recordPtr = TOP_RECORD(interp); + + if ((result == TCL_OK) && VALID_NEW_REQUEST(recordPtr)) { + switch(recordPtr->type) { + case TCL_NR_BC_TYPE: { + result = TclExecuteByteCode(interp, recordPtr->data.codePtr); + break; + } + case TCL_NR_CMD_TYPE: { + Tcl_Obj *objPtr = recordPtr->data.obj.objPtr; + int flags = recordPtr->data.obj.flags; + Tcl_Obj **objv; + int objc; + + Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); + result = Tcl_EvalObjv(interp, objc, objv, flags); + break; + } + case TCL_NR_SCRIPT_TYPE: { + Tcl_Obj *objPtr = recordPtr->data.obj.objPtr; + int flags = recordPtr->data.obj.flags; + + result = TclEvalObjEx(interp, objPtr, flags, NULL, 0); + break; + } + case TCL_NR_OBJPROC_TYPE: { + Tcl_ObjCmdProc *objProc = recordPtr->data.objProc.objProc; + ClientData clientData = recordPtr->data.objProc.clientData; + + if (!objc) { + Tcl_Panic("NRPostProcess: something is very wrong!"); + } + result = (*objProc)(clientData, interp, objc, objv); + break; + } + default: + Tcl_Panic("NRPostProcess: invalid record type"); + } + } + + assert((TOP_RECORD(interp) == recordPtr)); + return TclEvalObjv_NR2(interp, result, recordPtr->nextPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclNR_CreateCommand -- + * + * Define a new NRE-enabled object-based command in a command table. + * + * Results: + * The return value is a token for the command, which can be used in + * future calls to Tcl_GetCommandName. + * + * Side effects: + * If no command named "cmdName" already exists for interp, one is + * created. Otherwise, if a command does exist, then if the object-based + * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand + * was called previously for the same command and just set its + * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old + * command. + * + * In the future, during bytecode evaluation when "cmdName" is seen as + * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based + * Tcl_ObjCmdProc proc will be called. When the command is deleted from + * the table, deleteProc will be called. See the manual entry for details + * on the calling sequence. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclNR_CreateCommand( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ + const char *cmdName, /* Name of command. If it contains namespace + * qualifiers, the new command is put in the + * specified namespace; otherwise it is put in + * the global namespace. */ + Tcl_ObjCmdProc *proc, /* Object-based function to associate with + * name, provides direct access for direct calls */ + Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with + * name, provides NR implementation */ + ClientData clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc) + /* If not NULL, gives a function to call when + * this command is deleted. */ +{ + + Command *cmdPtr; + + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, cmdName, proc, clientData, + deleteProc); + cmdPtr->nreProc = nreProc; + return (Tcl_Command) cmdPtr; +} + +/* + * These are the previous contents of tclNRE.c, part of the NRE api. + * + */ + + +/* + * TclNREvalCmd should only be called as an optimisation: when objPtr is known + * to be a canonical list that is not (and will not!) be shared + */ + +int +TclNREvalCmd( + Tcl_Interp * interp, + Tcl_Obj * objPtr, + int flags) +{ + TEOV_record *recordPtr = TOP_RECORD(interp); + + Tcl_IncrRefCount(objPtr); + recordPtr->type = TCL_NR_CMD_TYPE; + recordPtr->data.obj.objPtr = objPtr; + recordPtr->data.obj.flags = flags; + return TCL_OK; +} + +/***************************************************************************** + * Stuff for the public api + *****************************************************************************/ + +int +TclNR_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, TCL_EVAL_INVOKE and + * TCL_EVAL_NOERR are currently supported. */ +{ + Tcl_Obj *listPtr = Tcl_NewListObj(objc, objv); + + return TclNREvalCmd(interp, listPtr, flags); +} + +int +TclNR_EvalObj( + Tcl_Interp * interp, + Tcl_Obj * objPtr, + int flags) +{ + TEOV_record *recordPtr = TOP_RECORD(interp); + List *listRep = objPtr->internalRep.twoPtrValue.ptr1; + + Tcl_IncrRefCount(objPtr); + if ((objPtr->typePtr == &tclListType) + && (!objPtr->bytes || listRep->canonicalFlag)) { + /* + * Shimmer protection! Always pass an unshared obj. The caller could + * incr the refCount of objPtr AFTER calling us! To be completely safe + * we always make a copy. + */ + + Tcl_Obj *origPtr = objPtr; + + objPtr = TclListObjCopy(NULL, origPtr); + Tcl_IncrRefCount(objPtr); + TclDecrRefCount(origPtr); + + recordPtr->type = TCL_NR_CMD_TYPE; + } else { + recordPtr->type = TCL_NR_SCRIPT_TYPE; + } + recordPtr->data.obj.objPtr = objPtr; + recordPtr->data.obj.flags = flags; + return TCL_OK; +} + +int +TclNR_ObjProc( + Tcl_Interp * interp, + Tcl_ObjCmdProc *objProc, + ClientData clientData) +{ + TEOV_record *recordPtr = TOP_RECORD(interp); + + recordPtr->type = TCL_NR_OBJPROC_TYPE; + recordPtr->data.objProc.objProc = objProc; + recordPtr->data.objProc.clientData = clientData; + return TCL_OK; +} + +/***************************************************************************** + * Stuff for tailcalls + *****************************************************************************/ + +/* + * Just to show that IT CAN BE DONE! The precise semantics are not simple, + * require more thought. Possibly need a new Tcl return code to do it right? + * Questions include: + * (1) How is the objc/objv tailcall to be run? My current thinking is that + * it should essentially be + * [tailcall a b c] <=> [uplevel 1 [list a b c]] + * with two caveats + * (a) the current frame is dropped first, after running all + * pending cleanup tasks and saving its namespace + * (b) 'a' is looked up in the returning frame's namespace, but the + * command is run in the context to which we are returning + * Current implementation does this if [tailcall] is called from within + * a proc, panics otherwise- + * (2) Should a tailcall bypass [catch] in the returning frame? Current + * implementation does not - it causes an error. + * + * FIXME! + */ + +int +TclTailcallObjCmd( + ClientData clientData, + Tcl_Interp * interp, + int objc, + Tcl_Obj *const objv[] ) +{ + Interp *iPtr = (Interp *) interp; + TEOV_record *recordPtr = TOP_RECORD(interp); + Tcl_Obj *listPtr; + + /* + * Do NOT allow tailcall to be called from a non-proc/lambda: tough to + * manage the proper semantics, especially for [uplevel $x tailcall foo] + */ + + if (!iPtr->varFramePtr->isProcCallFrame) { + Tcl_SetResult(interp, "tailcall can only be called from a proc or lambda", TCL_STATIC); + return TCL_ERROR; + } + + listPtr = Tcl_NewListObj(objc-1, objv+1); + TclNR_EvalObj(interp, listPtr, 0); + recordPtr->type = TCL_NR_TAILCALL_TYPE; + return TCL_OK; +} + +void TclNR_AddCallback( + Tcl_Interp *interp, + TclNR_PostProc *postProcPtr, + ClientData data0, + ClientData data1, + ClientData data2, + ClientData data3) +{ + TEOV_record *recordPtr; + TEOV_callback *callbackPtr; + + if (!postProcPtr) { + Tcl_Panic("Adding a callback without and objProc?!"); + } + + recordPtr = TOP_RECORD(interp); + TclSmallAlloc(sizeof(TEOV_callback), callbackPtr); + + callbackPtr->procPtr = postProcPtr; + callbackPtr->data0 = data0; + callbackPtr->data1 = data1; + callbackPtr->data2 = data2; + callbackPtr->data3 = data3; + + callbackPtr->nextPtr = recordPtr->callbackPtr; + recordPtr->callbackPtr = callbackPtr; +} + +TEOV_record * +TclNRPushRecord( + Tcl_Interp *interp) +{ + TEOV_record *recordPtr; + + PUSH_RECORD(interp, recordPtr); + return recordPtr; +} + +void +TclNRPopAndFreeRecord ( + Tcl_Interp * interp) +{ + TEOV_record *recordPtr; + + POP_RECORD(interp, recordPtr); + FREE_RECORD(interp, recordPtr); +} + + +/* * Local Variables: * mode: c * c-basic-offset: 4 |