diff options
author | Miguel Sofer <miguel.sofer@gmail.com> | 2008-07-13 09:03:31 (GMT) |
---|---|---|
committer | Miguel Sofer <miguel.sofer@gmail.com> | 2008-07-13 09:03:31 (GMT) |
commit | cbd9b876ccfb24791ac9576e49be51c579fa7a23 (patch) | |
tree | 7d872fa5186b327990fa96d969a3b092780f38d2 /generic | |
parent | 2603994d5d3ad503d97298c7fd1dc8f528694a19 (diff) | |
download | tcl-cbd9b876ccfb24791ac9576e49be51c579fa7a23.zip tcl-cbd9b876ccfb24791ac9576e49be51c579fa7a23.tar.gz tcl-cbd9b876ccfb24791ac9576e49be51c579fa7a23.tar.bz2 |
NRE implementation [Patch 2017110]
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tcl.decls | 35 | ||||
-rw-r--r-- | generic/tcl.h | 14 | ||||
-rw-r--r-- | generic/tclBasic.c | 1880 | ||||
-rw-r--r-- | generic/tclCmdAH.c | 5 | ||||
-rw-r--r-- | generic/tclCompile.h | 4 | ||||
-rw-r--r-- | generic/tclDecls.h | 76 | ||||
-rw-r--r-- | generic/tclExecute.c | 762 | ||||
-rw-r--r-- | generic/tclHistory.c | 4 | ||||
-rw-r--r-- | generic/tclInt.decls | 26 | ||||
-rw-r--r-- | generic/tclInt.h | 67 | ||||
-rw-r--r-- | generic/tclIntDecls.h | 64 | ||||
-rw-r--r-- | generic/tclInterp.c | 90 | ||||
-rw-r--r-- | generic/tclNamesp.c | 213 | ||||
-rw-r--r-- | generic/tclProc.c | 321 | ||||
-rw-r--r-- | generic/tclStubInit.c | 14 | ||||
-rw-r--r-- | generic/tclTestProcBodyObj.c | 6 |
16 files changed, 2609 insertions, 972 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 6c9b09a..460d6dc 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -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: tcl.decls,v 1.133 2008/06/13 05:45:07 mistachkin Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.134 2008/07/13 09:03:32 msofer Exp $ library tcl @@ -2108,6 +2108,39 @@ declare 581 generic { int Tcl_Canceled(Tcl_Interp *interp, int flags) } +# NRE public interface +declare 582 generic { + Tcl_Command TclNR_CreateCommand(Tcl_Interp *interp, + CONST char *cmdName, Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc) +} +declare 583 generic { + int TclNR_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) +} +declare 584 generic { + int TclNR_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], + int flags) +} +declare 585 generic { + int TclNR_ObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, + ClientData clientData) +} +declare 586 generic { + void TclNR_AddCallback(Tcl_Interp *interp, TclNR_PostProc *postProcPtr, + ClientData data0, ClientData data1, + ClientData data2, ClientData data3) +} + +# For use by NR extenders, to have a simple way to also provide a (required!) +# classic objProc +declare 587 generic { + int TclNR_CallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, + ClientData clientData, int objc, + Tcl_Obj *const objv[]) +} + + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tcl.h b/generic/tcl.h index 65c9eec..50bd3c1 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -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: tcl.h,v 1.259 2008/06/19 15:37:03 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.260 2008/07/13 09:03:32 msofer Exp $ */ #ifndef _TCL @@ -986,12 +986,15 @@ typedef struct Tcl_DString { * TCL_CANCEL_UNWIND: Magical Tcl_CancelEval mode that causes the * stack for the script in progress to be * completely unwound. + * TCL_EVAL_NOERR: Do no exception reporting at all, just return + * as the caller will report. */ #define TCL_NO_EVAL 0x10000 #define TCL_EVAL_GLOBAL 0x20000 #define TCL_EVAL_DIRECT 0x40000 #define TCL_EVAL_INVOKE 0x80000 #define TCL_CANCEL_UNWIND 0x100000 +#define TCL_EVAL_NOERR 0x200000 /* * Special freeProc values that may be passed to Tcl_SetResult (see the man @@ -2247,6 +2250,14 @@ EXTERN CONST char * Tcl_PkgInitStubsCheck _ANSI_ARGS_((Tcl_Interp *interp, EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr)); #endif + +/* + * Single public declaration for NRE + */ + +typedef int (TclNR_PostProc) (ClientData data[], Tcl_Interp *interp, + int result); + /* * Include the public function declarations that are accessible via the stubs * table. @@ -2426,6 +2437,7 @@ EXTERN void Tcl_GetMemoryInfo _ANSI_ARGS_((Tcl_DString *dsPtr)); # define panicVA Tcl_PanicVA #endif + /* * Convenience declaration of Tcl_AppInit for backwards compatibility. This * function is not *implemented* by the tcl library, so the storage class is 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 diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index d6127b0..1b90331 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.95 2008/05/30 22:54:27 dkf Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.96 2008/07/13 09:03:33 msofer Exp $ */ #include "tclInt.h" @@ -660,8 +660,7 @@ Tcl_EvalObjCmd( * TIP #280. Make invoking context available to eval'd script. */ - result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT, - iPtr->cmdFramePtr, 1); + result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT, iPtr->cmdFramePtr, 1); } else { /* * More than one argument: concatenate them together with spaces diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 7e6ff50..21ff9cc 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.92 2008/06/08 03:21:33 msofer Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.93 2008/07/13 09:03:33 msofer Exp $ */ #ifndef _TCLCOMPILATION @@ -840,7 +840,7 @@ MODULE_SCOPE int TclEvalObjvInternal(Tcl_Interp *interp, *---------------------------------------------------------------- */ -MODULE_SCOPE int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, +MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const CmdFrame *invoker, int word); /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index a09429a..5198401 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.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: tclDecls.h,v 1.134 2008/06/13 05:45:09 mistachkin Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.135 2008/07/13 09:03:33 msofer Exp $ */ #ifndef _TCLDECLS @@ -3513,6 +3513,50 @@ EXTERN int Tcl_CancelEval (Tcl_Interp * interp, /* 581 */ EXTERN int Tcl_Canceled (Tcl_Interp * interp, int flags); #endif +#ifndef TclNR_CreateCommand_TCL_DECLARED +#define TclNR_CreateCommand_TCL_DECLARED +/* 582 */ +EXTERN Tcl_Command TclNR_CreateCommand (Tcl_Interp * interp, + CONST char * cmdName, Tcl_ObjCmdProc * proc, + Tcl_ObjCmdProc * nreProc, + ClientData clientData, + Tcl_CmdDeleteProc * deleteProc); +#endif +#ifndef TclNR_EvalObj_TCL_DECLARED +#define TclNR_EvalObj_TCL_DECLARED +/* 583 */ +EXTERN int TclNR_EvalObj (Tcl_Interp * interp, Tcl_Obj * objPtr, + int flags); +#endif +#ifndef TclNR_EvalObjv_TCL_DECLARED +#define TclNR_EvalObjv_TCL_DECLARED +/* 584 */ +EXTERN int TclNR_EvalObjv (Tcl_Interp * interp, int objc, + Tcl_Obj *CONST objv[], int flags); +#endif +#ifndef TclNR_ObjProc_TCL_DECLARED +#define TclNR_ObjProc_TCL_DECLARED +/* 585 */ +EXTERN int TclNR_ObjProc (Tcl_Interp * interp, + Tcl_ObjCmdProc * objProc, + ClientData clientData); +#endif +#ifndef TclNR_AddCallback_TCL_DECLARED +#define TclNR_AddCallback_TCL_DECLARED +/* 586 */ +EXTERN void TclNR_AddCallback (Tcl_Interp * interp, + TclNR_PostProc * postProcPtr, + ClientData data0, ClientData data1, + ClientData data2, ClientData data3); +#endif +#ifndef TclNR_CallObjProc_TCL_DECLARED +#define TclNR_CallObjProc_TCL_DECLARED +/* 587 */ +EXTERN int TclNR_CallObjProc (Tcl_Interp * interp, + Tcl_ObjCmdProc * objProc, + ClientData clientData, int objc, + Tcl_Obj *const objv[]); +#endif typedef struct TclStubHooks { CONST struct TclPlatStubs *tclPlatStubs; @@ -4154,6 +4198,12 @@ typedef struct TclStubs { void (*tcl_AppendPrintfToObj) (Tcl_Obj * objPtr, CONST char * format, ...); /* 579 */ int (*tcl_CancelEval) (Tcl_Interp * interp, Tcl_Obj * resultObjPtr, ClientData clientData, int flags); /* 580 */ int (*tcl_Canceled) (Tcl_Interp * interp, int flags); /* 581 */ + Tcl_Command (*tclNR_CreateCommand) (Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, Tcl_ObjCmdProc * nreProc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc); /* 582 */ + int (*tclNR_EvalObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags); /* 583 */ + int (*tclNR_EvalObjv) (Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags); /* 584 */ + int (*tclNR_ObjProc) (Tcl_Interp * interp, Tcl_ObjCmdProc * objProc, ClientData clientData); /* 585 */ + void (*tclNR_AddCallback) (Tcl_Interp * interp, TclNR_PostProc * postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 586 */ + int (*tclNR_CallObjProc) (Tcl_Interp * interp, Tcl_ObjCmdProc * objProc, ClientData clientData, int objc, Tcl_Obj *const objv[]); /* 587 */ } TclStubs; #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) @@ -6554,6 +6604,30 @@ extern CONST TclStubs *tclStubsPtr; #define Tcl_Canceled \ (tclStubsPtr->tcl_Canceled) /* 581 */ #endif +#ifndef TclNR_CreateCommand +#define TclNR_CreateCommand \ + (tclStubsPtr->tclNR_CreateCommand) /* 582 */ +#endif +#ifndef TclNR_EvalObj +#define TclNR_EvalObj \ + (tclStubsPtr->tclNR_EvalObj) /* 583 */ +#endif +#ifndef TclNR_EvalObjv +#define TclNR_EvalObjv \ + (tclStubsPtr->tclNR_EvalObjv) /* 584 */ +#endif +#ifndef TclNR_ObjProc +#define TclNR_ObjProc \ + (tclStubsPtr->tclNR_ObjProc) /* 585 */ +#endif +#ifndef TclNR_AddCallback +#define TclNR_AddCallback \ + (tclStubsPtr->tclNR_AddCallback) /* 586 */ +#endif +#ifndef TclNR_CallObjProc +#define TclNR_CallObjProc \ + (tclStubsPtr->tclNR_CallObjProc) /* 587 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5587b48..690d190 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6,7 +6,7 @@ * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2002-2005 by Miguel Sofer. + * Copyright (c) 2002-2008 by Miguel Sofer. * Copyright (c) 2005-2007 by Donal K. Fellows. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. @@ -14,16 +14,20 @@ * 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.375 2008/06/30 01:10:46 das Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.376 2008/07/13 09:03:33 msofer Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include "tommath.h" +#include "tclNRE.h" #include <math.h> #include <float.h> +static TclNR_PostProc TailcallFromTebc; + + /* * Hack to determine whether we may expect IEEE floating point. The hack is * formally incorrect in that non-IEEE platforms might have the same precision @@ -163,6 +167,58 @@ static BuiltinFunc tclBuiltinFuncTable[] = { #endif /* + * NR_TEBC + * Helpers for NR - non-recursive calls to TEBC + */ + +typedef struct BottomData { +#if USE_NR_TEBC + struct BottomData *prevBottomPtr; + TEOV_record *recordPtr; /* Top record on TEOVI's cleanup stack when + * this level was entered. */ + ByteCode *codePtr; /* The following data is used on return */ + unsigned char *pc; /* TO this level: they record the state when */ + ptrdiff_t *catchTop; /* a new codePtr was received for NR */ + int cleanup; /* execution. */ + Tcl_Obj *auxObjList; +#endif +} BottomData; + +#if USE_NR_TEBC + +#define NR_DATA_INIT() \ + bottomPtr->prevBottomPtr = oldBottomPtr; \ + bottomPtr->recordPtr = TOP_RECORD(iPtr); \ + bottomPtr->codePtr = codePtr + +#define NR_DATA_BURY() \ + bottomPtr->pc = pc; \ + bottomPtr->catchTop = catchTop; \ + bottomPtr->cleanup = cleanup; \ + bottomPtr->auxObjList = auxObjList; \ + oldBottomPtr = bottomPtr + +#define NR_DATA_DIG() \ + pc = bottomPtr->pc; \ + codePtr = bottomPtr->codePtr; \ + catchTop = bottomPtr->catchTop; \ + cleanup = bottomPtr->cleanup; \ + auxObjList = bottomPtr->auxObjList; \ + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr +#endif + +#define PUSH_AUX_OBJ(objPtr) \ + objPtr->internalRep.twoPtrValue.ptr2 = auxObjList; \ + auxObjList = objPtr + +#define POP_AUX_OBJ() \ + { \ + Tcl_Obj *tmpPtr = auxObjList; \ + auxObjList = (Tcl_Obj *) tmpPtr->internalRep.twoPtrValue.ptr2; \ + Tcl_DecrRefCount(tmpPtr); \ + } + +/* * These variable-access macros have to coincide with those in tclVar.c */ @@ -746,6 +802,8 @@ TclCreateExecEnv( Tcl_IncrRefCount(eePtr->constants[0]); TclNewBooleanObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); + eePtr->recordPtr = NULL; + eePtr->tebcCall = 0; esPtr->prevPtr = NULL; esPtr->nextPtr = NULL; @@ -820,6 +878,9 @@ TclDeleteExecEnv( TclDecrRefCount(eePtr->constants[0]); TclDecrRefCount(eePtr->constants[1]); + if (eePtr->recordPtr) { + Tcl_Panic("Deleting execEnv with pending TEOV callbacks!"); + } ckfree((char *) eePtr); } @@ -1079,6 +1140,25 @@ StackReallocWords( } void +TclStackPurge( + Tcl_Interp *interp, + Tcl_Obj **tosPtr) +{ + Tcl_Obj **newTosPtr = GET_TOSPTR(interp); + + if (!tosPtr) { + Tcl_Panic("TclStackPurge: cannot purge to NULL"); + } + while (newTosPtr && (newTosPtr != tosPtr)) { + TclStackFree(interp, NULL); + newTosPtr = GET_TOSPTR(interp); + } + if (newTosPtr != tosPtr) { + Tcl_Panic("TclStackPurge: requested tosPtr not here"); + } +} + +void TclStackFree( Tcl_Interp *interp, void *freePtr) @@ -1103,7 +1183,7 @@ TclStackFree( esPtr = eePtr->execStackPtr; markerPtr = esPtr->markerPtr; - if (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr) { + if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) { Tcl_Panic("TclStackFree: incorrect freePtr. Call out of sequence?"); } @@ -1195,14 +1275,11 @@ TclStackRealloc( *-------------------------------------------------------------- */ -int -Tcl_ExprObj( - Tcl_Interp *interp, /* Context in which to evaluate the - * expression. */ - register Tcl_Obj *objPtr, /* Points to Tcl object containing expression - * to evaluate. */ - Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression - * result is stored if no errors occur. */ + +static ByteCode * +CompileExprObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) { Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated @@ -1210,14 +1287,6 @@ Tcl_ExprObj( register ByteCode *codePtr = NULL; /* Tcl Internal type of bytecode. Initialized * to avoid compiler warning. */ - int result; - - /* - * Execute the expression after first saving the interpreter's result. - */ - - Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(saveObjPtr); /* * Get the expression ByteCode from the object. If it exists, make sure it @@ -1274,6 +1343,31 @@ Tcl_ExprObj( } #endif /* TCL_COMPILE_DEBUG */ } + return codePtr; +} + +int +Tcl_ExprObj( + Tcl_Interp *interp, /* Context in which to evaluate the + * expression. */ + register Tcl_Obj *objPtr, /* Points to Tcl object containing expression + * to evaluate. */ + Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression + * result is stored if no errors occur. */ +{ + Interp *iPtr = (Interp *) interp; + int result; + ByteCode *codePtr; + + /* + * Execute the expression after first saving the interpreter's result. + */ + + Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(saveObjPtr); + + codePtr = CompileExprObj(interp, objPtr); + Tcl_ResetResult(interp); @@ -1377,24 +1471,21 @@ FreeExprCodeInternalRep( /* *---------------------------------------------------------------------- * - * TclCompEvalObj -- + * TclCompileObj -- * - * This procedure evaluates the script contained in a Tcl_Obj by first - * compiling it and then passing it to TclExecuteByteCode. + * This procedure compiles the script contained in a Tcl_Obj * * Results: - * The return value is one of the return codes defined in tcl.h (such as - * TCL_OK), and interp->objResultPtr refers to a Tcl object that either - * contains the result of executing the code or an error message. + * A pointer to the corresponding ByteCode * * Side effects: - * Almost certainly, depending on the ByteCode's instructions. + * The object is shimmered to bytecode type * *---------------------------------------------------------------------- */ -int -TclCompEvalObj( +ByteCode * +TclCompileObj( Tcl_Interp *interp, Tcl_Obj *objPtr, const CmdFrame *invoker, @@ -1402,7 +1493,6 @@ TclCompEvalObj( { register Interp *iPtr = (Interp *) interp; register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ - int result; Namespace *namespacePtr; /* @@ -1414,15 +1504,12 @@ TclCompEvalObj( TclResetCancellation(interp, 0); - iPtr->numLevels++; if (TclInterpReady(interp) == TCL_ERROR) { - result = TCL_ERROR; - goto done; + return NULL; } if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - result = TCL_ERROR; - goto done; + return NULL; } namespacePtr = iPtr->varFramePtr->nsPtr; @@ -1488,13 +1575,7 @@ TclCompEvalObj( */ runCompiledObj: - codePtr->refCount++; - result = TclExecuteByteCode(interp, codePtr); - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } - goto done; + return codePtr; } recompileObj: @@ -1516,11 +1597,7 @@ TclCompEvalObj( codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } - goto runCompiledObj; - - done: - iPtr->numLevels--; - return result; + goto runCompiledObj; } /* @@ -1687,6 +1764,23 @@ TclExecuteByteCode( #define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE) /* + * Bottom of allocated stack holds the NR data + */ + + int initLevel; + + /* NR_TEBC */ + + BottomData *bottomPtr; +#if USE_NR_TEBC + BottomData *oldBottomPtr = NULL; + + /* for tailcall support */ + Namespace *lookupNsPtr = NULL; + Tcl_Obj *tailObjPtr = NULL; +#endif + + /* * Constants: variables that do not change during the execution, used * sporadically. */ @@ -1706,11 +1800,11 @@ TclExecuteByteCode( ptrdiff_t *catchTop; register Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation * stack. */ - register unsigned char *pc = codePtr->codeStart; - /* The current program counter. */ + register unsigned char *pc; /* The current program counter. */ int instructionCount = 0; /* Counter that is used to work out when to * call Tcl_AsyncReady() */ - Tcl_Obj *expandNestList = NULL; + Tcl_Obj *auxObjList; /* Linked list of aux data, used for {*} and + * for same-level NR calls. */ int checkInterp = 0; /* Indicates when a check of interp readyness * is necessary. Set by CACHE_STACK_INFO() */ @@ -1739,11 +1833,11 @@ TclExecuteByteCode( int traceInstructions = (tclTraceExec == 3); char cmdNameBuf[21]; #endif - char *curInstName = NULL; - + char *curInstName; + /* - * The execution uses a unified stack: first the catch stack, immediately - * above it a CmdFrame, then the execution stack. + * The execution uses a unified stack: first a BottomData, immediately + * above it a CmdFrame, then the catch stack, then the execution stack. * * Make sure the catch stack is large enough to hold the maximum number of * catch commands that could ever be executing at the same time (this will @@ -1751,30 +1845,115 @@ TclExecuteByteCode( * execution stack is large enough to execute this ByteCode. */ - catchTop = initCatchTop = (ptrdiff_t *) ( - GrowEvaluationStack(iPtr->execEnvPtr, - codePtr->maxExceptDepth + sizeof(CmdFrame) + - codePtr->maxStackDepth, 0) - 1); - bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1); - tosPtr = initTosPtr = ((Tcl_Obj **) (bcFramePtr + 1)) - 1; - esPtr = iPtr->execEnvPtr->execStackPtr; - /* - * TIP #280: Initialize the frame. Do not push it yet. + * NR_TEBC */ + +#if USE_NR_TEBC + nonRecursiveCallStart: +#endif + codePtr->refCount++; + bottomPtr = (BottomData *) GrowEvaluationStack(iPtr->execEnvPtr, + sizeof(BottomData) + codePtr->maxExceptDepth + sizeof(CmdFrame) + + codePtr->maxStackDepth, 0); + curInstName = NULL; + auxObjList = NULL; + initLevel = 1; + +#if USE_NR_TEBC + NR_DATA_INIT(); /* record this level's data */ + + nonRecursiveCallReturn: +#endif + bcFramePtr = (CmdFrame *) (bottomPtr + 1); + initCatchTop = ((ptrdiff_t *) (bcFramePtr + 1)) - 1; + initTosPtr = (Tcl_Obj **) (initCatchTop + codePtr->maxExceptDepth); + esPtr = iPtr->execEnvPtr->execStackPtr; - bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) - ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); - bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); - bcFramePtr->framePtr = iPtr->framePtr; - bcFramePtr->nextPtr = iPtr->cmdFramePtr; - bcFramePtr->nline = 0; - bcFramePtr->line = NULL; + namespacePtr = iPtr->varFramePtr->nsPtr; + compiledLocals = iPtr->varFramePtr->compiledLocals; - bcFramePtr->data.tebc.codePtr = codePtr; - bcFramePtr->data.tebc.pc = NULL; - bcFramePtr->cmd.str.cmd = NULL; - bcFramePtr->cmd.str.len = 0; + if (initLevel) { + initLevel = 0; + pc = codePtr->codeStart; + catchTop = initCatchTop; + tosPtr = initTosPtr; + + /* + * TIP #280: Initialize the frame. Do not push it yet. + */ + + bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) + ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); + bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); + bcFramePtr->framePtr = iPtr->framePtr; + bcFramePtr->nextPtr = iPtr->cmdFramePtr; + bcFramePtr->nline = 0; + bcFramePtr->line = NULL; + + bcFramePtr->data.tebc.codePtr = codePtr; + bcFramePtr->data.tebc.pc = NULL; + bcFramePtr->cmd.str.cmd = NULL; + bcFramePtr->cmd.str.len = 0; +#if USE_NR_TEBC + } else if (tailObjPtr) { + /* + * A request to perform a tailcall; a frame has already been dropped, + * so we just have to ... + * (Note that we already have a refcount for tailObjPtr!) + */ + + *++tosPtr = tailObjPtr; + tailObjPtr = NULL; + iPtr->lookupNsPtr = lookupNsPtr; + lookupNsPtr = NULL; + + /* + * Fake pc, INST_EVAL STK will fix this and resume properly + */ + pc--; + goto tailCallEntryPoint; +#endif + } else { + /* + * Returning from a non-recursive call. State is already completely + * reset, now process the return. + */ + + if (result == TCL_OK) { + /* + * Reset the interp's result to avoid possible duplications of + * large objects [Bug 781585]. We do not call Tcl_ResetResult + * to avoid any side effects caused by the resetting of + * errorInfo and errorCode [Bug 804681], which are not needed + * here. We chose instead to manipulate the interp's object + * result directly. + * + * Note that the result object is now in objResultPtr, it + * keeps the refCount it had in its role of + * iPtr->objResultPtr. + */ + +#ifndef TCL_COMPILE_DEBUG + if (*pc == INST_POP) { + pc++; + } else { +#endif + objResultPtr = Tcl_GetObjResult(interp); + *(++tosPtr) = objResultPtr; + + TclNewObj(objResultPtr); + Tcl_IncrRefCount(objResultPtr); + iPtr->objResultPtr = objResultPtr; +#ifndef TCL_COMPILE_DEBUG + } +#endif + } else { + cleanup = 0; /* already cleaned up */ + pc--; /* was pointing to next instruction */ + goto processExceptionReturn; + } + } #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { @@ -1788,9 +1967,6 @@ TclExecuteByteCode( iPtr->stats.numExecutions++; #endif - namespacePtr = iPtr->varFramePtr->nsPtr; - compiledLocals = iPtr->varFramePtr->compiledLocals; - /* * Loop executing instructions until a "done" instruction, a TCL_RETURN, * or some error. @@ -1866,7 +2042,7 @@ TclExecuteByteCode( */ ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0, - /*checkStack*/ expandNestList == NULL); + /*checkStack*/ auxObjList == NULL); if (traceInstructions) { fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); TclPrintInstruction(codePtr, pc); @@ -1920,7 +2096,7 @@ TclExecuteByteCode( } } - TCL_DTRACE_INST_NEXT(); + TCL_DTRACE_INST_NEXT(); /* * These two instructions account for 26% of all instructions (according @@ -2251,7 +2427,7 @@ TclExecuteByteCode( case INST_EXPAND_START: { /* - * Push an element to the expandNestList. This records the current + * Push an element to the auxObjList. This records the current * stack depth - i.e., the point in the stack where the expanded * command starts. * @@ -2267,8 +2443,7 @@ TclExecuteByteCode( TclNewObj(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (void *) CURR_DEPTH; - objPtr->internalRep.twoPtrValue.ptr2 = (void *) expandNestList; - expandNestList = objPtr; + PUSH_AUX_OBJ(objPtr); NEXT_INST_F(1, 0, 0); } @@ -2301,14 +2476,15 @@ TclExecuteByteCode( length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1)); DECACHE_STACK_INFO(); - moved = (GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - 1) - - (Tcl_Obj **) initCatchTop; + moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) + - (Tcl_Obj **) bottomPtr; if (moved) { /* * Change the global data to point to the new stack. */ + bottomPtr = (BottomData *) (((Tcl_Obj **)bottomPtr) + moved); initCatchTop += moved; catchTop += moved; initTosPtr += moved; @@ -2335,15 +2511,134 @@ TclExecuteByteCode( */ int objc, pcAdjustment; + Tcl_Obj **objv; + + case INST_EXPR_STK: { + /* + * Moved here to support transforming the eval of an expression to + * a non-recursive TEBC call. + */ + +#if (USE_NR_TEBC) + + pcAdjustment = 1; + cleanup = 1; + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + DECACHE_STACK_INFO(); + TEBC_DATA(iPtr) = CompileExprObj(interp, OBJ_AT_TOS); + CACHE_STACK_INFO(); + goto tebc_do_exec; +#else + Tcl_Obj *objPtr, *valuePtr; + + objPtr = OBJ_AT_TOS; + + DECACHE_STACK_INFO(); + /*Tcl_ResetResult(interp);*/ + result = Tcl_ExprObj(interp, objPtr, &valuePtr); + CACHE_STACK_INFO(); + if (result == TCL_OK) { + objResultPtr = valuePtr; + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + NEXT_INST_F(1, 1, -1); /* Already has right refct. */ + } else { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + cleanup = 1; + goto checkForCatch; + } +#endif + } + + + tailCallEntryPoint: + case INST_EVAL_STK: { + /* + * Moved here to support transforming the eval of objects to a + * simple command invocation (for canonical lists) or a + * non-recursive TEBC call (compiled scripts). + */ + + Tcl_Obj *objPtr = OBJ_AT_TOS; + ByteCode *newCodePtr; + + pcAdjustment = 1; + cleanup = 1; + + if (objPtr->typePtr == &tclListType) { /* is a list... */ + List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; + + if (objPtr->bytes == NULL || /* ...without a string rep */ + listRepPtr->canonicalFlag) {/* ...or that is canonical */ + objc = listRepPtr->elemCount; + objv = &listRepPtr->elements; + goto doInvocationFromEval; + } + } + + /* + * TIP #280: The invoking context is left NULL for a dynamically + * constructed command. We cannot match its lines to the outer + * context. + */ + + DECACHE_STACK_INFO(); + newCodePtr = TclCompileObj(interp, objPtr, NULL, 0); + if (newCodePtr) { + /* + * Run the bytecode in this same TEBC instance! + */ +#if (USE_NR_TEBC) + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + TEBC_DATA(iPtr) = newCodePtr; + goto tebc_do_exec; +#else + result = TclExecuteByteCode(interp, newCodePtr); + CACHE_STACK_INFO(); + + if (result == TCL_OK) { + /* + * Normal return; push the eval's object result. + */ + + objResultPtr = Tcl_GetObjResult(interp); + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + + /* + * Reset the interp's result to avoid possible duplications of + * large objects [Bug 781585]. We do not call Tcl_ResetResult to + * avoid any side effects caused by the resetting of errorInfo and + * errorCode [Bug 804681], which are not needed here. We chose + * instead to manipulate the interp's object result directly. + * + * Note that the result object is now in objResultPtr, it keeps + * the refCount it had in its role of iPtr->objResultPtr. + */ + + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; + NEXT_INST_F(1, 1, -1); + } +#endif + } + + /* + * Compilation failed, error + */ + + result = TCL_ERROR; + goto processExceptionReturn; + } case INST_INVOKE_EXPANDED: { - Tcl_Obj *objPtr = expandNestList; - - expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; objc = CURR_DEPTH - - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1; - TclDecrRefCount(objPtr); + - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1; + POP_AUX_OBJ(); } if (objc) { @@ -2369,7 +2664,9 @@ TclExecuteByteCode( doInvocation: { - Tcl_Obj **objv = &OBJ_AT_DEPTH(objc-1); + objv = &OBJ_AT_DEPTH(objc-1); + cleanup = objc; + doInvocationFromEval: #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { @@ -2392,14 +2689,7 @@ TclExecuteByteCode( #endif /*TCL_COMPILE_DEBUG*/ /* - * Reset the instructionCount variable, since we're about to check - * for async stuff anyway while processing TclEvalObjvInternal. - */ - - instructionCount = 1; - - /* - * Finally, let TclEvalObjvInternal handle the command. + * Finally, let Tcl_EvalObjv handle the command. * * TIP #280: Record the last piece of info needed by * 'TclGetSrcInfoForPc', and push the frame. @@ -2407,10 +2697,62 @@ TclExecuteByteCode( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; + + /* + * Reset the instructionCount variable, since we're about to check + * for async stuff anyway while processing Tcl_EvalObjv + */ + + instructionCount = 1; + DECACHE_STACK_INFO(); - result = TclEvalObjvInternal(interp, objc, objv, - /* call from TEBC */(char *) -1, -1, 0); + + TEBC_CALL(iPtr) = 1; + result = Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_NOERR); CACHE_STACK_INFO(); +#if (USE_NR_TEBC) + switch (TEBC_CALL(iPtr)) { + case TEBC_DO_EXEC: { + tebc_do_exec: + /* + * A request to execute a bytecode came back. We save + * the current state and restart at the top. + */ + assert((result == TCL_OK)); + TEBC_CALL(iPtr) = 0; + pc += pcAdjustment; + NR_DATA_BURY(); /* this level's state variables */ + codePtr = TEBC_DATA(iPtr); + result = TCL_OK; + goto nonRecursiveCallStart; + } + case TEBC_DO_TAILCALL: { + /* + * A request to perform a tailcall: save the current + * namespace, drop a frame and eval the passed listObj + * in the previous frame while looking up the command + * in the current namespace. Read it again. + * + * We take over tailObjPtr's refcount! + */ + + assert((result == TCL_OK)); + TEBC_CALL(iPtr) = 0; + tailObjPtr = TEBC_DATA(iPtr); + if (catchTop != initCatchTop) { + result = TCL_ERROR; + Tcl_SetResult(interp,"Tailcall called from within a catch environment", + TCL_STATIC); + Tcl_DecrRefCount(tailObjPtr); + tailObjPtr = NULL; + goto checkForCatch; + } + lookupNsPtr = iPtr->varFramePtr->nsPtr; + result = TCL_OK; + goto abnormalReturn; /* drop a level */ + } + } +#endif iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; if (result == TCL_OK) { @@ -2418,7 +2760,7 @@ TclExecuteByteCode( #ifndef TCL_COMPILE_DEBUG if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), objc, 0); + NEXT_INST_V((pcAdjustment+1), cleanup, 0); } #endif /* @@ -2447,9 +2789,8 @@ TclExecuteByteCode( TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; - NEXT_INST_V(pcAdjustment, objc, -1); + NEXT_INST_V(pcAdjustment, cleanup, -1); } else { - cleanup = objc; goto processExceptionReturn; } } @@ -2548,74 +2889,6 @@ TclExecuteByteCode( #endif } - case INST_EVAL_STK: { - /* - * Note to maintainers: it is important that INST_EVAL_STK pop its - * argument from the stack before jumping to checkForCatch! DO NOT - * OPTIMISE! - */ - - Tcl_Obj *objPtr = OBJ_AT_TOS; - - DECACHE_STACK_INFO(); - - /* - * TIP #280: The invoking context is left NULL for a dynamically - * constructed command. We cannot match its lines to the outer - * context. - */ - - result = TclCompEvalObj(interp, objPtr, NULL, 0); - CACHE_STACK_INFO(); - if (result == TCL_OK) { - /* - * Normal return; push the eval's object result. - */ - - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - - /* - * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult to - * avoid any side effects caused by the resetting of errorInfo and - * errorCode [Bug 804681], which are not needed here. We chose - * instead to manipulate the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it keeps - * the refCount it had in its role of iPtr->objResultPtr. - */ - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_F(1, 1, -1); - } else { - cleanup = 1; - goto processExceptionReturn; - } - } - - case INST_EXPR_STK: { - Tcl_Obj *objPtr, *valuePtr; - - objPtr = OBJ_AT_TOS; - DECACHE_STACK_INFO(); - /*Tcl_ResetResult(interp);*/ - result = Tcl_ExprObj(interp, objPtr, &valuePtr); - CACHE_STACK_INFO(); - if (result == TCL_OK) { - objResultPtr = valuePtr; - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); - NEXT_INST_F(1, 1, -1); /* Already has right refct. */ - } else { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - goto checkForCatch; - } - } - /* * --------------------------------------------------------- * Start of INST_LOAD instructions. @@ -5043,8 +5316,7 @@ TclExecuteByteCode( invalid = 0; } if (invalid) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("negative shift argument", -1)); + Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); result = TCL_ERROR; goto checkForCatch; } @@ -5078,8 +5350,7 @@ TclExecuteByteCode( * place to draw the line. */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); + Tcl_SetResult(interp, "integer value too large to represent", TCL_STATIC); result = TCL_ERROR; goto checkForCatch; } @@ -5771,8 +6042,7 @@ TclExecuteByteCode( } } if (type2 == TCL_NUMBER_BIG) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("exponent too large", -1)); + Tcl_SetResult(interp, "exponent too large", TCL_STATIC); result = TCL_ERROR; goto checkForCatch; } @@ -6207,8 +6477,7 @@ TclExecuteByteCode( break; case INST_EXPON: if (big2.used > 1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("exponent too large", -1)); + Tcl_SetResult(interp, "exponent too large", TCL_STATIC); mp_clear(&big1); mp_clear(&big2); mp_clear(&bigResult); @@ -7222,7 +7491,7 @@ TclExecuteByteCode( */ divideByZero: - Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); + Tcl_SetResult(interp, "divide by zero", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); result = TCL_ERROR; @@ -7234,8 +7503,7 @@ TclExecuteByteCode( */ exponOfZero: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "exponentiation of zero by negative power", -1)); + Tcl_SetResult(interp, "exponentiation of zero by negative power", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); result = TCL_ERROR; @@ -7361,13 +7629,13 @@ TclExecuteByteCode( * INST_BEGIN_CATCH. */ - while ((expandNestList != NULL) && ((catchTop == initCatchTop) || - (*catchTop <= - (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) { - Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; - - TclDecrRefCount(expandNestList); - expandNestList = objPtr; + while (auxObjList) { + if ((catchTop != initCatchTop) && + (*catchTop > + (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) { + break; + } + POP_AUX_OBJ(); } /* @@ -7417,7 +7685,7 @@ TclExecuteByteCode( /* * This is only possible when compiling a [catch] that sends its * script to INST_EVAL. Cannot correct the compiler without - * breakingcompat with previous .tbc compiled scripts. + * breaking compat with previous .tbc compiled scripts. */ #ifdef TCL_COMPILE_DEBUG @@ -7465,22 +7733,22 @@ TclExecuteByteCode( abnormalReturn: TCL_DTRACE_INST_LAST(); + /* + * Clear all expansions and same-level NR calls. + * + * Note that expansion markers have a NULL type; avoid removing other + * markers. + */ + + while (auxObjList) { + POP_AUX_OBJ(); + } while (tosPtr > initTosPtr) { Tcl_Obj *objPtr = POP_OBJECT(); Tcl_DecrRefCount(objPtr); } - /* - * Clear all expansions. - */ - - while (expandNestList) { - Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; - - TclDecrRefCount(expandNestList); - expandNestList = objPtr; - } if (tosPtr < initTosPtr) { fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: " @@ -7491,14 +7759,104 @@ TclExecuteByteCode( } } +#if USE_NR_TEBC + oldBottomPtr = bottomPtr->prevBottomPtr; +#endif + TclStackFree(interp, bottomPtr); /* free my stack */ + + if (--codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + +#if USE_NR_TEBC + if (oldBottomPtr) { + /* + * Restore the state to what it was previous to this bytecode. + * + * NR_TEBC + */ + + bottomPtr = oldBottomPtr; /* back to old bc */ + + /* Please free anything that might still be on my new stack */ + result = TclEvalObjv_NR2(interp, result, bottomPtr->recordPtr); + assert((TOP_RECORD(iPtr) == bottomPtr->recordPtr)); + + /* restore state variables */ + NR_DATA_DIG(); + esPtr = iPtr->execEnvPtr->execStackPtr; + tosPtr = esPtr->tosPtr; + while (cleanup--) { + Tcl_Obj *objPtr = POP_OBJECT(); + Tcl_DecrRefCount(objPtr); + } + CACHE_STACK_INFO(); + goto nonRecursiveCallReturn; + } + + if (tailObjPtr && result == TCL_OK) { + /* + * The best we can do here is to add the tailcall at the FRONT of the + * callback list. This will be a real tailcall if we're lucky to have + * been called from TEOV (or similar), and not-quite-but-almost if + * called from eg TclOO (I think). + * The simplest way to add to the front is: + * (a) push a new record + * (b) add the tailcall as callback to the newly-created 2nd record + * (c) swap the two top records: old top is still top, newly created + * record is second + */ + + TEOV_record *rootPtr, *recordPtr; + + rootPtr = TOP_RECORD(iPtr); + PUSH_RECORD(iPtr, recordPtr); + TclNR_AddCallback(interp, TailcallFromTebc, tailObjPtr, lookupNsPtr, NULL, NULL); + + /* Now swap them! */ + recordPtr->nextPtr = rootPtr->nextPtr; + rootPtr->nextPtr = recordPtr; + TOP_RECORD(iPtr) = rootPtr; + } +#endif + return result; +} + +static int +TailcallFromTebc( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *tailObjPtr = data[0]; + Namespace *lookupNsPtr = data[1]; + int objc; + Tcl_Obj **objv; + + Tcl_IncrRefCount(tailObjPtr); /* unshared per construction! */ + if (result != TCL_OK) { + goto done; + } + result = Tcl_ListObjGetElements(NULL, tailObjPtr, &objc, &objv); + if (result != TCL_OK) { + /* shouldn't happen */ + goto done; + } + /* - * Restore the stack to the state it had previous to this bytecode. + * Note that by this time the proc's frame SHOULD BE ALREADY POPPED! We do + * as if it was (don't know what happens with eg TclOO), ie, assume that + * are already in [uplevel 1] from the proc's callFrame.. */ - TclStackFree(interp, initCatchTop+1); + iPtr->lookupNsPtr = lookupNsPtr; + result = Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_INVOKE); + + done: + Tcl_DecrRefCount(tailObjPtr); return result; -#undef iPtr } +#undef iPtr #ifdef TCL_COMPILE_DEBUG /* diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 0a01019..ea1a8ff 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.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: tclHistory.c,v 1.11 2008/04/27 22:21:30 dkf Exp $ + * RCS: @(#) $Id: tclHistory.c,v 1.12 2008/07/13 09:03:33 msofer Exp $ */ #include "tclInt.h" @@ -123,7 +123,7 @@ Tcl_RecordAndEvalObj( result = Tcl_GetCommandInfo(interp, "history", &info); - if (result && (info.objProc == TclObjInterpProc)) { + if (result && (info.deleteProc == TclProcDeleteProc)) { Proc *procPtr = (Proc *)(info.objClientData); call = (procPtr->cmdPtr->compileProc != TclCompileNoOp); } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index e05298a..f5be70a 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -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: tclInt.decls,v 1.123 2008/07/08 17:52:17 dgp Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.124 2008/07/13 09:03:33 msofer Exp $ library tcl @@ -940,6 +940,30 @@ declare 237 generic { int TclResetCancellation(Tcl_Interp *interp, int force) } +# NRE functions for "rogue" extensions to exploit NRE; they will need to +# include NRE.h too. +declare 238 generic { + int TclEvalObjv_NR2(Tcl_Interp *interp, int result, + struct TEOV_record *rootPtr) +} +declare 239 generic { + Tcl_ObjCmdProc TclNRInterpProc +} +declare 240 generic { + int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, + int skip, ProcErrorProc errorProc) +} +declare 241 generic { + struct TEOV_record * TclNRPushRecord(Tcl_Interp *interp) +} +declare 242 generic { + void TclNRPopAndFreeRecord(Tcl_Interp *interp) +} + +declare 243 generic { + int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, + const CmdFrame *invoker, int word) +} ############################################################################## # Define the platform specific internal Tcl interface. These functions are diff --git a/generic/tclInt.h b/generic/tclInt.h index 112421d..9e0f6ce 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.371 2008/06/13 05:45:12 mistachkin Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.372 2008/07/13 09:03:34 msofer Exp $ */ #ifndef _TCLINT @@ -1308,10 +1308,20 @@ typedef struct ExecStack { * currently active execution stack. */ +struct TEOV_record; + typedef struct ExecEnv { - ExecStack *execStackPtr; /* Points to the first item in the evaluation - * stack on the heap. */ - Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */ + ExecStack *execStackPtr; /* Points to the first item in the + * evaluation stack on the heap. */ + Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" + * objs. */ + struct TEOV_record *recordPtr; /* Top record in TEOV's stack */ + int tebcCall; /* used to distinguish tebc calls from + * other calls to TEOV, and other comms + * between TEBC and TEOV */ + ClientData tebcData; /* used by TEOV to pass data to its + * calling TEBC */ + } ExecEnv; /* @@ -1502,6 +1512,7 @@ typedef struct Command { * command. */ CommandTrace *tracePtr; /* First in list of all traces set for this * command. */ + Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command */ } Command; /* @@ -1525,9 +1536,9 @@ typedef struct Command { * (these last two flags are defined in tcl.h) */ -#define CMD_IS_DELETED 0x1 -#define CMD_TRACE_ACTIVE 0x2 -#define CMD_HAS_EXEC_TRACES 0x4 +#define CMD_IS_DELETED 0x1 +#define CMD_TRACE_ACTIVE 0x2 +#define CMD_HAS_EXEC_TRACES 0x4 /* *---------------------------------------------------------------- @@ -2469,6 +2480,10 @@ MODULE_SCOPE char tclEmptyString; *---------------------------------------------------------------- */ +MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd; +MODULE_SCOPE int TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr, + int flags); + MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, const char *end); MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, @@ -2481,6 +2496,8 @@ MODULE_SCOPE double TclCeil(mp_int *a); MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); +MODULE_SCOPE int TclClearRootEnsemble(ClientData data[], + Tcl_Interp *interp, int result); MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); MODULE_SCOPE int TclDoubleDigits(char *buf, double value, int *signum); @@ -2614,9 +2631,6 @@ MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); -#ifndef TCL_NO_STACK_CHECK -MODULE_SCOPE int TclpGetCStackParams(int **stackBoundPtr); -#endif MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, @@ -3886,6 +3900,39 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum, ? 1 : 0))) +/* + *---------------------------------------------------------------- + * Allocator for small structs (<=sizeof(Tcl_Obj)) using the Tcl_Obj + * pool. Only checked at compile time. + * + * ONLY USE FOR CONSTANT nBytes: if you do and nBytes is too large, the + * compiler will error out with "duplicate case value" (thanks dkf!). If the + * size is dynamic, a panic will be compiled in for the wrong case. + * + * DO NOT LET THEM CROSS THREAD BOUNDARIES + */ + +#define TclSmallAlloc(nbytes, memPtr) \ + { \ + Tcl_Obj *objPtr; \ + switch ((nbytes)>sizeof(Tcl_Obj)) { \ + case (2 +((nbytes)>sizeof(Tcl_Obj))): \ + case 3: \ + case 1: \ + Tcl_Panic("TclSmallAlloc: nBytes too large!"); \ + case 0: (void)0; \ + } \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + memPtr = (ClientData) objPtr; \ + } + +#define TclSmallFree(memPtr) \ + TclFreeObjStorage((Tcl_Obj *) memPtr); \ + TclIncrObjsFreed() + + + #include "tclPort.h" #include "tclIntDecls.h" #include "tclIntPlatDecls.h" diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index d21bd4d..6dc36c0 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -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: tclIntDecls.h,v 1.117 2008/07/08 17:52:17 dgp Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.118 2008/07/13 09:03:35 msofer Exp $ */ #ifndef _TCLINTDECLS @@ -1076,6 +1076,38 @@ EXTERN void TclBackgroundException (Tcl_Interp * interp, /* 237 */ EXTERN int TclResetCancellation (Tcl_Interp * interp, int force); #endif +#ifndef TclEvalObjv_NR2_TCL_DECLARED +#define TclEvalObjv_NR2_TCL_DECLARED +/* 238 */ +EXTERN int TclEvalObjv_NR2 (Tcl_Interp * interp, int result, + struct TEOV_record * rootPtr); +#endif +/* 239 */ +EXTERN Tcl_ObjCmdProc TclNRInterpProc; +#ifndef TclNRInterpProcCore_TCL_DECLARED +#define TclNRInterpProcCore_TCL_DECLARED +/* 240 */ +EXTERN int TclNRInterpProcCore (Tcl_Interp * interp, + Tcl_Obj * procNameObj, int skip, + ProcErrorProc errorProc); +#endif +#ifndef TclNRPushRecord_TCL_DECLARED +#define TclNRPushRecord_TCL_DECLARED +/* 241 */ +EXTERN struct TEOV_record * TclNRPushRecord (Tcl_Interp * interp); +#endif +#ifndef TclNRPopAndFreeRecord_TCL_DECLARED +#define TclNRPopAndFreeRecord_TCL_DECLARED +/* 242 */ +EXTERN void TclNRPopAndFreeRecord (Tcl_Interp * interp); +#endif +#ifndef TclNREvalObjEx_TCL_DECLARED +#define TclNREvalObjEx_TCL_DECLARED +/* 243 */ +EXTERN int TclNREvalObjEx (Tcl_Interp * interp, + Tcl_Obj * objPtr, int flags, + const CmdFrame * invoker, int word); +#endif typedef struct TclIntStubs { int magic; @@ -1343,6 +1375,12 @@ typedef struct TclIntStubs { void (*tclInitVarHashTable) (TclVarHashTable * tablePtr, Namespace * nsPtr); /* 235 */ void (*tclBackgroundException) (Tcl_Interp * interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp * interp, int force); /* 237 */ + int (*tclEvalObjv_NR2) (Tcl_Interp * interp, int result, struct TEOV_record * rootPtr); /* 238 */ + Tcl_ObjCmdProc *tclNRInterpProc; /* 239 */ + int (*tclNRInterpProcCore) (Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); /* 240 */ + struct TEOV_record * (*tclNRPushRecord) (Tcl_Interp * interp); /* 241 */ + void (*tclNRPopAndFreeRecord) (Tcl_Interp * interp); /* 242 */ + int (*tclNREvalObjEx) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags, const CmdFrame * invoker, int word); /* 243 */ } TclIntStubs; #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) @@ -2088,6 +2126,30 @@ extern CONST TclIntStubs *tclIntStubsPtr; #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #endif +#ifndef TclEvalObjv_NR2 +#define TclEvalObjv_NR2 \ + (tclIntStubsPtr->tclEvalObjv_NR2) /* 238 */ +#endif +#ifndef TclNRInterpProc +#define TclNRInterpProc \ + (*tclIntStubsPtr->tclNRInterpProc) /* 239 */ +#endif +#ifndef TclNRInterpProcCore +#define TclNRInterpProcCore \ + (tclIntStubsPtr->tclNRInterpProcCore) /* 240 */ +#endif +#ifndef TclNRPushRecord +#define TclNRPushRecord \ + (tclIntStubsPtr->tclNRPushRecord) /* 241 */ +#endif +#ifndef TclNRPopAndFreeRecord +#define TclNRPopAndFreeRecord \ + (tclIntStubsPtr->tclNRPopAndFreeRecord) /* 242 */ +#endif +#ifndef TclNREvalObjEx +#define TclNREvalObjEx \ + (tclIntStubsPtr->tclNREvalObjEx) /* 243 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index c681da5..c4f8515 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.86 2008/06/20 20:48:47 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.87 2008/07/13 09:03:35 msofer Exp $ */ #include "tclInt.h" @@ -196,6 +196,9 @@ static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); static int AliasObjCmd(ClientData dummy, Tcl_Interp *currentInterp, int objc, Tcl_Obj *const objv[]); +static int AliasNRCmd(ClientData dummy, + Tcl_Interp *currentInterp, int objc, + Tcl_Obj *const objv[]); static void AliasObjCmdDeleteProc(ClientData clientData); static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr); static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc, @@ -1482,9 +1485,15 @@ AliasCreate( Tcl_Preserve(slaveInterp); Tcl_Preserve(masterInterp); + if (slaveInterp == masterInterp) { + aliasPtr->slaveCmd = TclNR_CreateCommand(slaveInterp, + TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr, + AliasObjCmdDeleteProc); + } else { aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, TclGetString(namePtr), AliasObjCmd, aliasPtr, AliasObjCmdDeleteProc); + } if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) { @@ -1739,6 +1748,69 @@ AliasList( */ static int +AliasNRCmd( + ClientData clientData, /* Alias record. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument vector. */ +{ + Interp *iPtr = (Interp *) interp; + Alias *aliasPtr = clientData; + int prefc, cmdc, i; + Tcl_Obj **prefv, **cmdv; + int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + Tcl_Obj *listPtr; + List *listRep; + int flags = TCL_EVAL_INVOKE; + + /* + * Append the arguments to the command prefix and invoke the command in + * the target interp's global namespace. + */ + + prefc = aliasPtr->objc; + prefv = &aliasPtr->objPtr; + cmdc = prefc + objc - 1; + + listPtr = Tcl_NewListObj(cmdc, NULL); + listRep = listPtr->internalRep.twoPtrValue.ptr1; + listRep->elemCount = cmdc; + cmdv = &listRep->elements; + + prefv = &aliasPtr->objPtr; + memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); + memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); + + for (i=0; i<cmdc; i++) { + Tcl_IncrRefCount(cmdv[i]); + } + + /* + * Use the ensemble rewriting machinery to ensure correct error messages: + * only the source command should show, not the full target prefix. + */ + + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 1; + iPtr->ensembleRewrite.numInsertedObjs = prefc; + } else { + iPtr->ensembleRewrite.numInsertedObjs += prefc - 1; + } + + /* + * We are sending a 0-refCount obj, do not need a callback: it will be + * cleaned up automatically. But we may need to clear the rootEnsemble + * stuff ... + */ + + if (isRootEnsemble) { + TclNR_AddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); + } + return TclNREvalCmd(interp, listPtr, flags); +} + +static int AliasObjCmd( ClientData clientData, /* Alias record. */ Tcl_Interp *interp, /* Current interpreter. */ @@ -2542,10 +2614,24 @@ SlaveEval( if (objc == 1) { /* * TIP #280: Make invoker available to eval'd script. + * + * Do not let any intReps accross, with the exception of + * bytecodes. The intrep spoiling is due to happen anyway when + * compiling. */ Interp *iPtr = (Interp *) interp; - result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr, 0); + + objPtr = objv[0]; + if (objPtr->typePtr + && (objPtr->typePtr != &tclByteCodeType) + && objPtr->typePtr->freeIntRepProc) { + (void) TclGetString(objPtr); + TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; + } + + result = TclEvalObjEx(slaveInterp, objPtr, 0, iPtr->cmdFramePtr, 0); } else { objPtr = Tcl_ConcatObj(objc, objv); Tcl_IncrRefCount(objPtr); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index cf39f90..a0a651b 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -23,7 +23,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.164 2008/05/22 15:22:07 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.165 2008/07/13 09:03:35 msofer Exp $ */ #include "tclInt.h" @@ -169,6 +169,8 @@ static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); static int InvokeImportedCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int InvokeImportedNRCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceChildrenCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp, @@ -212,6 +214,8 @@ static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int NsEnsembleImplementationCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NsEnsembleImplementationCmdNR(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); static int NsEnsembleStringOrder(const void *strPtr1, const void *strPtr2); @@ -224,6 +228,8 @@ static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); static void UnlinkNsPath(Namespace *nsPtr); +static TclNR_PostProc NsEval_Callback; + /* * This structure defines a Tcl object type that contains a namespace * reference. It is used in commands that take the name of a namespace as an @@ -1638,8 +1644,8 @@ DoImport( } dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); - importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), - InvokeImportedCmd, dataPtr, DeleteImportedCmd); + importedCmd = TclNR_CreateCommand(interp, Tcl_DStringValue(&ds), + InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; @@ -1876,6 +1882,25 @@ TclGetOriginalCommand( */ static int +InvokeImportedNRCmd( + ClientData clientData, /* Points to the imported command's + * ImportedCmdData structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + register ImportedCmdData *dataPtr = clientData; + register Command *realCmdPtr = dataPtr->realCmdPtr; + + if (!realCmdPtr->nreProc) { + return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, + objc, objv); + } + return (*realCmdPtr->nreProc)(realCmdPtr->objClientData, interp, + objc, objv); +} + +static int InvokeImportedCmd( ClientData clientData, /* Points to the imported command's * ImportedCmdData structure. */ @@ -2772,6 +2797,16 @@ Tcl_NamespaceObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return TclNR_CallObjProc(interp, TclNRNamespaceObjCmd, clientData, objc, objv); +} + +int +TclNRNamespaceObjCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ static const char *subCmds[] = { "children", "code", "current", "delete", "ensemble", "eval", "exists", "export", "forget", "import", @@ -3225,12 +3260,42 @@ NamespaceDeleteCmd( */ static int +NsEval_Callback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Namespace *namespacePtr = data[0]; + + if (result == TCL_ERROR) { + int length = strlen(namespacePtr->fullName); + int limit = 200; + int overflow = (length > limit); + char *cmd = data[1]; + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in namespace %s \"%.*s%s\" script line %d)", + cmd, + (overflow ? limit : length), namespacePtr->fullName, + (overflow ? "..." : ""), interp->errorLine)); + } + + /* + * Restore the previous "current" namespace. + */ + + TclPopStackFrame(interp); + return result; +} + +static int NamespaceEvalCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Interp *iPtr = (Interp *) interp; Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; Tcl_Obj *objPtr; @@ -3278,13 +3343,7 @@ NamespaceEvalCmd( framePtr->objv = objv; if (objc == 4) { - /* - * TIP #280: Make invoker available to eval'd script. - */ - - Interp *iPtr = (Interp *) interp; - - result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr, 3); + objPtr = objv[3]; } else { /* * More than one argument: concatenate them together with spaces @@ -3293,31 +3352,14 @@ NamespaceEvalCmd( */ objPtr = Tcl_ConcatObj(objc-3, objv+3); - - /* - * TIP #280: Make invoking context available to eval'd script. - */ - - result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); } - - if (result == TCL_ERROR) { - int length = strlen(namespacePtr->fullName); - int limit = 200; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in namespace eval \"%.*s%s\" script line %d)", - (overflow ? limit : length), namespacePtr->fullName, - (overflow ? "..." : ""), interp->errorLine)); - } - + /* - * Restore the previous "current" namespace. + * TIP #280: Make invoking context available to eval'd script. */ - - TclPopStackFrame(interp); - return result; + + TclNR_AddCallback(interp, NsEval_Callback, namespacePtr, "eval", NULL, NULL); + return TclNREvalObjEx(interp, objPtr, 0, iPtr->cmdFramePtr, 3); } /* @@ -3675,6 +3717,7 @@ NamespaceInscopeCmd( Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; int i, result; + Tcl_Obj *cmdObjPtr; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); @@ -3712,10 +3755,10 @@ NamespaceInscopeCmd( */ if (objc == 4) { - result = Tcl_EvalObjEx(interp, objv[3], 0); + cmdObjPtr = objv[3]; } else { Tcl_Obj *concatObjv[2]; - register Tcl_Obj *listPtr, *cmdObjPtr; + register Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); for (i = 4; i < objc; i++) { @@ -3728,27 +3771,11 @@ NamespaceInscopeCmd( concatObjv[0] = objv[3]; concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); - result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); Tcl_DecrRefCount(listPtr); /* We're done with the list object. */ } - if (result == TCL_ERROR) { - int length = strlen(namespacePtr->fullName); - int limit = 200; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in namespace inscope \"%.*s%s\" script line %d)", - (overflow ? limit : length), namespacePtr->fullName, - (overflow ? "..." : ""), interp->errorLine)); - } - - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; + TclNR_AddCallback(interp, NsEval_Callback, namespacePtr, "inscope", NULL, NULL); + return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0); } /* @@ -5293,8 +5320,9 @@ Tcl_CreateEnsemble( ensemblePtr->subcommandDict = NULL; ensemblePtr->flags = flags; ensemblePtr->unknownHandler = NULL; - ensemblePtr->token = Tcl_CreateObjCommand(interp, name, - NsEnsembleImplementationCmd, ensemblePtr, DeleteEnsembleConfig); + ensemblePtr->token = TclNR_CreateCommand(interp, name, + NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, + ensemblePtr, DeleteEnsembleConfig); ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; @@ -6013,6 +6041,32 @@ NsEnsembleImplementationCmd( int objc, Tcl_Obj *const objv[]) { + return TclNR_CallObjProc(interp, NsEnsembleImplementationCmdNR, + clientData, objc, objv); +} + +int +TclClearRootEnsemble( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + + return result; +} + +static int +NsEnsembleImplementationCmdNR( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ EnsembleConfig *ensemblePtr = clientData; /* The ensemble itself. */ Tcl_Obj **tempObjv; /* Space used to construct the list of @@ -6179,8 +6233,9 @@ NsEnsembleImplementationCmd( { Interp *iPtr = (Interp *) interp; - int isRootEnsemble; - Tcl_Obj *copyObj; + int isRootEnsemble, i, tempObjc; + Tcl_Obj *copyPtr; + List *listRepPtr; /* * Get the prefix that we're rewriting to. To do this we need to @@ -6189,8 +6244,23 @@ NsEnsembleImplementationCmd( * elements in the list. */ - copyObj = TclListObjCopy(NULL, prefixObj); - TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); + TclListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv); + + tempObjc = objc - 2 + prefixObjc; + copyPtr = Tcl_NewListObj(tempObjc, NULL); + if (tempObjc > 0) { + listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; + listRepPtr->elemCount = tempObjc; + tempObjv = &listRepPtr->elements; + + memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); + memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + + for (i=0; i < tempObjc; i++) { + Tcl_IncrRefCount(tempObjv[i]); + } + } + Tcl_DecrRefCount(prefixObj); /* * Record what arguments the script sent in so that things like @@ -6214,36 +6284,15 @@ NsEnsembleImplementationCmd( } /* - * Allocate a workspace and build the list of arguments to pass to the - * target command in it. - */ - - 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)); - - /* * Hand off to the target command. */ - result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, - TCL_EVAL_INVOKE); - - /* - * Clean up. - */ - - TclStackFree(interp, tempObjv); - Tcl_DecrRefCount(copyObj); if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = NULL; - iPtr->ensembleRewrite.numRemovedObjs = 0; - iPtr->ensembleRewrite.numInsertedObjs = 0; + TclNR_AddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } + + return TclNREvalCmd(interp, copyPtr, TCL_EVAL_INVOKE); } - Tcl_DecrRefCount(prefixObj); - return result; unknownOrAmbiguousSubcommand: /* diff --git a/generic/tclProc.c b/generic/tclProc.c index 42f65ba..90cac16 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -12,11 +12,21 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.142 2008/06/13 05:45:14 mistachkin Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.143 2008/07/13 09:03:35 msofer Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include "tclNRE.h" + +typedef struct { + int isRootEnsemble; + Command cmd; + ExtraFrameInfo efi; +} ApplyExtraData; + +static TclNR_PostProc ApplyNR2; +static TclNR_PostProc InterpProcNR2; /* * Prototypes for static functions in this file @@ -47,6 +57,8 @@ static int ProcCompileProc(Tcl_Interp *interp, Proc *procPtr, const char *description, const char *procName, Proc **procPtrPtr); +static TclNR_PostProc Uplevel_Callback; + /* * The ProcBodyObjType type */ @@ -185,9 +197,8 @@ Tcl_ProcObjCmd( } Tcl_DStringAppend(&ds, procName, -1); - cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), - TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); - + cmd = TclNR_CreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, + TclNRInterpProc, (ClientData) procPtr, TclProcDeleteProc); Tcl_DStringFree(&ds); /* @@ -864,6 +875,27 @@ TclObjGetFrame( *---------------------------------------------------------------------- */ +static int +Uplevel_Callback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CallFrame *savedVarFramePtr = data[0]; + + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"uplevel\" body line %d)", interp->errorLine)); + } + + /* + * Restore the variable frame, and return. + */ + + ((Interp *)interp)->varFramePtr = savedVarFramePtr; + return result; +} + /* ARGSUSED */ int Tcl_UplevelObjCmd( @@ -872,9 +904,21 @@ Tcl_UplevelObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return TclNR_CallObjProc(interp, TclNRUplevelObjCmd, dummy, objc, objv); +} + +int +TclNRUplevelObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr, *framePtr; + Tcl_Obj *objPtr; if (objc < 2) { uplevelSyntax: @@ -908,7 +952,7 @@ Tcl_UplevelObjCmd( */ if (objc == 1) { - result = Tcl_EvalObjEx(interp, objv[0], 0); + objPtr = objv[0]; } else { /* * More than one argument: concatenate them together with spaces @@ -916,22 +960,11 @@ Tcl_UplevelObjCmd( * object when it decrements its refcount after eval'ing it. */ - Tcl_Obj *objPtr; - objPtr = Tcl_ConcatObj(objc, objv); - result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); - } - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"uplevel\" body line %d)", interp->errorLine)); } - /* - * Restore the variable frame, and return. - */ - - iPtr->varFramePtr = savedVarFramePtr; - return result; + TclNR_AddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL, NULL); + return TclNREvalObjEx(interp, objPtr, 0, NULL, 0); } /* @@ -963,7 +996,6 @@ TclFindProc( const char *procName) /* Name of desired procedure. */ { Tcl_Command cmd; - Tcl_Command origCmd; Command *cmdPtr; cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0); @@ -972,14 +1004,7 @@ TclFindProc( } cmdPtr = (Command *) cmd; - origCmd = TclGetOriginalCommand(cmd); - if (origCmd != NULL) { - cmdPtr = (Command *) origCmd; - } - if (cmdPtr->objProc != TclObjInterpProc) { - return NULL; - } - return (Proc *) cmdPtr->objClientData; + return TclIsProc(cmdPtr); } /* @@ -1010,7 +1035,7 @@ TclIsProc( if (origCmd != NULL) { cmdPtr = (Command *) origCmd; } - if (cmdPtr->objProc == TclObjInterpProc) { + if (cmdPtr->deleteProc == TclProcDeleteProc) { return (Proc *) cmdPtr->objClientData; } return (Proc *) 0; @@ -1581,6 +1606,23 @@ PushProcCallFrame( return TCL_OK; } + +static int +TclNR_BC( + Tcl_Interp * interp, + ByteCode *codePtr, + TclNR_PostProc *postProcPtr, + Tcl_Obj *procNameObj, + ProcErrorProc errorProc) +{ + TEOV_record *recordPtr = TOP_RECORD(interp); + + recordPtr->type = TCL_NR_BC_TYPE; + recordPtr->data.codePtr = codePtr; + TclNR_AddCallback(interp, postProcPtr, procNameObj, errorProc, NULL, NULL); + return TCL_OK; +} + /* *---------------------------------------------------------------------- * @@ -1610,6 +1652,10 @@ TclObjInterpProc( { int result; + /* + * Not used in the core; external interface for iTcl and XOTcl + */ + result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); if (result == TCL_OK) { return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); @@ -1617,6 +1663,26 @@ TclObjInterpProc( return TCL_ERROR; } } + +int +TclNRInterpProc( + ClientData clientData, /* Record describing procedure to be + * interpreted. */ + register Tcl_Interp *interp,/* Interpreter in which procedure was + * invoked. */ + int objc, /* Count of number of arguments to this + * procedure. */ + Tcl_Obj *CONST objv[]) /* Argument value objects. */ +{ + int result; + + result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); + if (result == TCL_OK) { + return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); + } else { + return TCL_ERROR; + } +} /* *---------------------------------------------------------------------- @@ -1646,14 +1712,59 @@ TclObjInterpProcCore( ProcErrorProc errorProc) /* How to convert results from the script into * results of the overall procedure. */ { + /* + * Not used in the core; external interface for TclOO + */ + + Interp *iPtr = (Interp *) interp; + TEOV_record record, *rootPtr; + int result; + + /* + * Put a top record NOT ON THE TCL STACK! Note that TclNRInterpProcCore + * assumes it can free the CallFrame in the error case, there cannot be + * anything else on top of that. We use a C-stack record, it could also be + * ckalloc'ed or anything else, just NOT TclStackAlloc. + */ + + rootPtr = TOP_RECORD(iPtr); + TOP_RECORD(iPtr) = &record; + result = TclNRInterpProcCore(interp, procNameObj, skip, errorProc); + TOP_RECORD(iPtr) = rootPtr; + + if (result == TCL_OK) { + result = TclExecuteByteCode(interp, record.data.codePtr); + result = TclEvalObjv_NR2(interp, result, rootPtr); + result = InterpProcNR2(&record.callbackPtr->data0, interp, result); + TclSmallFree(record.callbackPtr); + } + return result; +} + +int +TclNRInterpProcCore( + register Tcl_Interp *interp,/* Interpreter in which procedure was + * invoked. */ + Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ + int skip, /* Number of initial arguments to be skipped, + * i.e., words in the "command name". */ + ProcErrorProc errorProc) /* How to convert results from the script into + * results of the overall procedure. */ +{ Interp *iPtr = (Interp *) interp; register Proc *procPtr = iPtr->varFramePtr->procPtr; int result; CallFrame *freePtr; + ByteCode *codePtr; result = InitArgsAndLocals(interp, procNameObj, skip); if (result != TCL_OK) { - goto procDone; + freePtr = iPtr->framePtr; + Tcl_PopCallFrame(interp); /* Pop but do not free. */ + TclStackFree(interp, freePtr->compiledLocals); + /* Free compiledLocals. */ + TclStackFree(interp, freePtr); /* Free CallFrame. */ + return TCL_ERROR; } #if defined(TCL_COMPILE_DEBUG) @@ -1703,36 +1814,37 @@ TclObjInterpProcCore( TclResetCancellation(interp, 0); procPtr->refCount++; - iPtr->numLevels++; + codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { + int l; + + l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1; + TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj), + iPtr->varFramePtr->objc - l, + (Tcl_Obj **)(iPtr->varFramePtr->objv + l)); + } - if (TclInterpReady(interp) == TCL_ERROR) { - result = TCL_ERROR; - } else { - register ByteCode *codePtr = - procPtr->bodyPtr->internalRep.otherValuePtr; + TclNR_BC(interp, codePtr, InterpProcNR2, procNameObj, errorProc); + + return TCL_OK; +} - codePtr->refCount++; - if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l; - - l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1; - TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj), - iPtr->varFramePtr->objc - l, - (Tcl_Obj **)(iPtr->varFramePtr->objv + l)); - } - result = TclExecuteByteCode(interp, codePtr); - if (TCL_DTRACE_PROC_RETURN_ENABLED()) { - TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result); - } - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } +static int +InterpProcNR2( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Proc *procPtr = iPtr->varFramePtr->procPtr; + CallFrame *freePtr; + Tcl_Obj *procNameObj = data[0]; + ProcErrorProc errorProc = data[1]; + + if (TCL_DTRACE_PROC_RETURN_ENABLED()) { + TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result); } - - iPtr->numLevels--; - procPtr->refCount--; - if (procPtr->refCount <= 0) { + if (--procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } @@ -1798,7 +1910,6 @@ TclObjInterpProcCore( TclGetString(r), r); } - procDone: /* * Free the stack-allocated compiled locals and CallFrame. It is important * to pop the call frame without freeing it first: the compiledLocals @@ -1812,6 +1923,7 @@ TclObjInterpProcCore( TclStackFree(interp, freePtr->compiledLocals); /* Free compiledLocals. */ TclStackFree(interp, freePtr); /* Free CallFrame. */ + return result; } @@ -2591,13 +2703,23 @@ Tcl_ApplyObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return TclNR_CallObjProc(interp, TclNRApplyObjCmd, dummy, objc, objv); +} + + +int +TclNRApplyObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ +{ Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr; int result, isRootEnsemble; - Command cmd; Tcl_Namespace *nsPtr; - ExtraFrameInfo efi; + ApplyExtraData *extraPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?"); @@ -2615,6 +2737,12 @@ Tcl_ApplyObjCmd( } #define JOE_EXTENSION 0 +/* + * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT + * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt + * the code. (MS) + */ + #if JOE_EXTENSION else { /* @@ -2641,8 +2769,21 @@ Tcl_ApplyObjCmd( procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } - memset(&cmd, 0, sizeof(Command)); - procPtr->cmdPtr = &cmd; + /* + * Find the namespace where this lambda should run, and push a call frame + * for that namespace. Note that TclObjInterpProc() will pop it. + */ + + nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return TCL_ERROR; + } + + extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData)); + memset(&extraPtr->cmd, 0, sizeof(Command)); + procPtr->cmdPtr = &extraPtr->cmd; + extraPtr->cmd.nsPtr = (Namespace *) nsPtr; /* * TIP#280 (semi-)HACK! @@ -2654,24 +2795,11 @@ Tcl_ApplyObjCmd( * 'hPtr', and lambda's never. */ - efi.length = 1; - efi.fields[0].name = "lambda"; - efi.fields[0].proc = NULL; - efi.fields[0].clientData = lambdaPtr; - cmd.clientData = &efi; - - /* - * Find the namespace where this lambda should run, and push a call frame - * for that namespace. Note that TclObjInterpProc() will pop it. - */ - - nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return result; - } - - cmd.nsPtr = (Namespace *) nsPtr; + extraPtr->efi.length = 1; + extraPtr->efi.fields[0].name = "lambda"; + extraPtr->efi.fields[0].proc = NULL; + extraPtr->efi.fields[0].clientData = lambdaPtr; + extraPtr->cmd.clientData = &extraPtr->efi; isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); if (isRootEnsemble) { @@ -2681,18 +2809,43 @@ Tcl_ApplyObjCmd( } else { iPtr->ensembleRewrite.numInsertedObjs -= 1; } + extraPtr->isRootEnsemble = isRootEnsemble; result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1); if (result == TCL_OK) { - result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError); + result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); + if (result == TCL_OK) { + /* Fix the recordPtr! */ + + TEOV_record *recordPtr = TOP_RECORD(iPtr); + recordPtr->callbackPtr->procPtr = ApplyNR2; + recordPtr->callbackPtr->data2 = extraPtr; + } } + if (result != TCL_OK) { + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = NULL; + } + TclStackFree(interp, extraPtr); + } + return result; +} - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = NULL; - iPtr->ensembleRewrite.numRemovedObjs = 0; - iPtr->ensembleRewrite.numInsertedObjs = 0; +static int +ApplyNR2( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ApplyExtraData *extraPtr = data[2]; + + result = InterpProcNR2(data, interp, result); + + if (extraPtr->isRootEnsemble) { + ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL; } + TclStackFree(interp, extraPtr); return result; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b02c4d0..61e8ad1 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.155 2008/07/08 17:52:17 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.156 2008/07/13 09:03:35 msofer Exp $ */ #include "tclInt.h" @@ -307,6 +307,12 @@ static const TclIntStubs tclIntStubs = { TclInitVarHashTable, /* 235 */ TclBackgroundException, /* 236 */ TclResetCancellation, /* 237 */ + TclEvalObjv_NR2, /* 238 */ + &TclNRInterpProc, /* 239 */ + TclNRInterpProcCore, /* 240 */ + TclNRPushRecord, /* 241 */ + TclNRPopAndFreeRecord, /* 242 */ + TclNREvalObjEx, /* 243 */ }; static const TclIntPlatStubs tclIntPlatStubs = { @@ -1102,6 +1108,12 @@ static const TclStubs tclStubs = { Tcl_AppendPrintfToObj, /* 579 */ Tcl_CancelEval, /* 580 */ Tcl_Canceled, /* 581 */ + TclNR_CreateCommand, /* 582 */ + TclNR_EvalObj, /* 583 */ + TclNR_EvalObjv, /* 584 */ + TclNR_ObjProc, /* 585 */ + TclNR_AddCallback, /* 586 */ + TclNR_CallObjProc, /* 587 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index db390a1..d346d59 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.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: tclTestProcBodyObj.c,v 1.6 2008/04/27 22:21:32 dkf Exp $ + * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.7 2008/07/13 09:03:35 msofer Exp $ */ #include "tclInt.h" @@ -255,10 +255,10 @@ ProcBodyTestProcObjCmd( /* * check that this is a procedure and not a builtin command: - * If a procedure, cmdPtr->objProc is TclObjInterpProc. + * If a procedure, cmdPtr->objClientData is TclIsProc(cmdPtr). */ - if (cmdPtr->objProc != TclGetObjInterpProc()) { + if (cmdPtr->objClientData != TclIsProc(cmdPtr)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", fullName, "\" is not a Tcl procedure", NULL); return TCL_ERROR; |