diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 13 | ||||
| -rw-r--r-- | generic/tclExecute.c | 14 | ||||
| -rw-r--r-- | generic/tclInt.h | 8 | ||||
| -rw-r--r-- | generic/tclInterp.c | 109 |
4 files changed, 132 insertions, 12 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 0c57652..e686237 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -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: tclBasic.c,v 1.295.2.18 2010/07/25 10:13:49 nijtmans Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.295.2.19 2010/11/15 21:32:31 andreas_kupries Exp $ */ #include "tclInt.h" @@ -501,6 +501,15 @@ Tcl_CreateInterp(void) iPtr->resultSpace[0] = 0; iPtr->threadId = Tcl_GetCurrentThread(); + /* TIP #378 */ +#ifdef TCL_INTERP_DEBUG_FRAME + iPtr->flags |= INTERP_DEBUG_FRAME; +#else + if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) { + iPtr->flags |= INTERP_DEBUG_FRAME; + } +#endif + /* * Initialise the tables for variable traces and searches *before* * creating the global ns - so that the trace on errorInfo can be @@ -3442,7 +3451,9 @@ int TclInterpReady( Tcl_Interp *interp) { +#if !defined(TCL_NO_STACK_CHECK) int localInt; /* used for checking the stack */ +#endif register Interp *iPtr = (Interp *) interp; /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d70fcba..2f38758 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.369.2.18 2010/10/09 16:31:28 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.369.2.19 2010/11/15 21:32:31 andreas_kupries Exp $ */ #include "tclInt.h" @@ -2412,14 +2412,18 @@ TclExecuteByteCode( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; - TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } DECACHE_STACK_INFO(); result = TclEvalObjvInternal(interp, objc, objv, /* call from TEBC */(char *) -1, -1, 0); CACHE_STACK_INFO(); - TclArgumentBCRelease((Tcl_Interp*) iPtr, objv, objc, - codePtr, pc - codePtr->codeStart); + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCRelease((Tcl_Interp *) iPtr, objv, objc, + codePtr, pc - codePtr->codeStart); + } iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; if (result == TCL_OK) { diff --git a/generic/tclInt.h b/generic/tclInt.h index eb88ef0..31c9628 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -13,12 +13,14 @@ * 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.362.2.14 2010/07/25 10:13:48 nijtmans Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.362.2.15 2010/11/15 21:32:32 andreas_kupries Exp $ */ #ifndef _TCLINT #define _TCLINT +#define TCL_NO_STACK_CHECK /* DISABLE C RUNTIME STACK CHECK - Test AIX */ + /* * Some numerics configuration options. */ @@ -2032,6 +2034,9 @@ typedef struct InterpList { * SAFE_INTERP: Non zero means that the current interp is a safe * interp (i.e. it has only the safe commands installed, * less priviledge than a regular interp). + * INTERP_DEBUG_FRAME: Used for switching on various extra interpreter + * debug/info mechanisms (e.g. info frame eval/uplevel + * tracing) which are performance intensive. * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be * invoked. @@ -2047,6 +2052,7 @@ typedef struct InterpList { #define DELETED 1 #define ERR_ALREADY_LOGGED 4 +#define INTERP_DEBUG_FRAME 0x10 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 diff --git a/generic/tclInterp.c b/generic/tclInterp.c index e7ad80d..219b059 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.83.2.4 2009/12/29 13:13:18 dkf Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.83.2.5 2010/11/15 21:32:32 andreas_kupries Exp $ */ #include "tclInt.h" @@ -207,6 +207,9 @@ static int SlaveBgerror(Tcl_Interp *interp, Tcl_Obj *const objv[]); static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, int safe); +static int SlaveDebugCmd(Tcl_Interp *interp, + Tcl_Interp *slaveInterp, + int objc, Tcl_Obj *const objv[]); static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); static int SlaveExpose(Tcl_Interp *interp, @@ -558,7 +561,7 @@ Tcl_InterpObjCmd( int index; static const char *options[] = { "alias", "aliases", "bgerror", "create", - "delete", "eval", "exists", "expose", + "debug", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit","slaves", "share", "target", "transfer", @@ -566,7 +569,7 @@ Tcl_InterpObjCmd( }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE, - OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, + OPT_DEBUG, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER @@ -706,6 +709,23 @@ Tcl_InterpObjCmd( Tcl_SetObjResult(interp, slavePtr); return TCL_OK; } + case OPT_DEBUG: { + /* TIP #378 */ + Tcl_Interp *slaveInterp; + + /* + * Currently only -frame supported, otherwise ?-option ?value?? + */ + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); + } case OPT_DELETE: { int i; InterpInfo *iiPtr; @@ -2228,12 +2248,12 @@ SlaveObjCmd( Tcl_Interp *slaveInterp = clientData; int index; static const char *options[] = { - "alias", "aliases", "bgerror", "eval", + "alias", "aliases", "bgerror", "debug", "eval", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", NULL }; enum options { - OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_EVAL, + OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT }; @@ -2280,6 +2300,16 @@ SlaveObjCmd( return TCL_ERROR; } return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); + case OPT_DEBUG: + /* + * TIP #378 * + * Currently only -frame supported, otherwise ?-option ?value? ...? + */ + if (objc > 4) { + Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??"); + return TCL_ERROR; + } + return SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2); case OPT_EVAL: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); @@ -2443,6 +2473,75 @@ SlaveObjCmdDeleteProc( /* *---------------------------------------------------------------------- * + * SlaveDebugCmd -- TIP #378 + * + * Helper function to handle 'debug' command in a slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May modify INTERP_DEBUG flag in the slave. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveDebugCmd( + Tcl_Interp *interp, /* Interp for error return. */ + Tcl_Interp *slaveInterp, /* The slave interpreter in which command + * will be evaluated. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const debugTypes[] = { + "-frame", NULL + }; + enum DebugTypes { + DEBUG_TYPE_FRAME + }; + int debugType; + Interp *iPtr; + Tcl_Obj *resultPtr; + + iPtr = (Interp *) slaveInterp; + if (objc == 0) { + resultPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj("-frame", -1)); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME)); + Tcl_SetObjResult(interp, resultPtr); + } else { + if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, + "debug option", 0, &debugType) != TCL_OK) { + return TCL_ERROR; + } + if (debugType == DEBUG_TYPE_FRAME) { + if (objc == 2) { /* set */ + if (Tcl_GetBooleanFromObj(interp, objv[1], &debugType) + != TCL_OK) { + return TCL_ERROR; + } + /* + * Quietly ignore attempts to disable interp debugging. + * This is a one-way switch as frame debug info is maintained + * in a stack that must be consistent once turned on. + */ + if (debugType) { + iPtr->flags |= INTERP_DEBUG_FRAME; + } + } + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME)); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * SlaveEval -- * * Helper function to evaluate a command in a slave interpreter. |