summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2006-09-30 17:56:45 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2006-09-30 17:56:45 (GMT)
commit7d238aee5a63e4f16bafa9863ec090f904e66df2 (patch)
treead9a7220c6ca69cd16f1f4d0574ec34d46c1ad63 /generic
parent858a806396de6a90554a6ebd0ce288b554f61ac7 (diff)
downloadtcl-7d238aee5a63e4f16bafa9863ec090f904e66df2.zip
tcl-7d238aee5a63e4f16bafa9863ec090f904e66df2.tar.gz
tcl-7d238aee5a63e4f16bafa9863ec090f904e66df2.tar.bz2
* generic/tclCompile.c:
* generic/tclHistory.c: * generic/tclInt.h: * generic/tclProc.c: made Tcl_RecordAndEvalObj not call "history" if it has been redefined to an empty proc, in order to reduce the noise when debugging [FR 1190441]. Moved TclCompileNoOp from tclProc.c to tclCompile.c
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCompile.c47
-rw-r--r--generic/tclHistory.c45
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclProc.c47
4 files changed, 80 insertions, 63 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 2be8b05..ddaee64 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.97 2006/08/29 06:28:38 das Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.98 2006/09/30 17:56:46 msofer Exp $
*/
#include "tclInt.h"
@@ -1636,6 +1636,51 @@ TclCompileExprWords(
/*
*----------------------------------------------------------------------
*
+ * TclCompileNoOp --
+ *
+ * Function called to compile no-op's
+ *
+ * Results:
+ * The return value is TCL_OK, indicating successful compilation.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute a no-op at runtime. No
+ * result is pushed onto the stack: the compiler has to take care of this
+ * itself if the last compiled command is a NoOp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileNoOp(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ int i;
+ int savedStackDepth = envPtr->currStackDepth;
+
+ tokenPtr = parsePtr->tokenPtr;
+ for(i = 1; i < parsePtr->numWords; i++) {
+ tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
+ envPtr->currStackDepth = savedStackDepth;
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
+ envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ }
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclInitByteCodeObj --
*
* Create a ByteCode structure and initialize it from a CompileEnv
diff --git a/generic/tclHistory.c b/generic/tclHistory.c
index daef8f3..e77b230 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.8 2005/10/18 14:34:41 dkf Exp $
+ * RCS: @(#) $Id: tclHistory.c,v 1.9 2006/09/30 17:56:47 msofer Exp $
*/
#include "tclInt.h"
@@ -112,29 +112,44 @@ Tcl_RecordAndEvalObj(
* in global variable context instead of the
* current procedure. */
{
- int result;
+ int result, call = 1;
Tcl_Obj *list[3];
register Tcl_Obj *objPtr;
+ Tcl_CmdInfo info;
/*
- * Do recording by eval'ing a tcl history command: history add $cmd.
+ * Do not call [history] if it has been replaced by an empty proc
*/
- list[0] = Tcl_NewStringObj("history", -1);
- list[1] = Tcl_NewStringObj("add", -1);
- list[2] = cmdPtr;
+ result = Tcl_GetCommandInfo(interp, "history", &info);
- objPtr = Tcl_NewListObj(3, list);
- Tcl_IncrRefCount(objPtr);
- (void) Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
- Tcl_DecrRefCount(objPtr);
+ if (result && (info.objProc == TclObjInterpProc)) {
+ Proc *procPtr = (Proc *)(info.objClientData);
+ call = (procPtr->cmdPtr->compileProc != TclCompileNoOp);
+ }
- /*
- * One possible failure mode above: exceeding a resource limit.
- */
+ if (call) {
- if (Tcl_LimitExceeded(interp)) {
- return TCL_ERROR;
+ /*
+ * Do recording by eval'ing a tcl history command: history add $cmd.
+ */
+
+ list[0] = Tcl_NewStringObj("history", -1);
+ list[1] = Tcl_NewStringObj("add", -1);
+ list[2] = cmdPtr;
+
+ objPtr = Tcl_NewListObj(3, list);
+ Tcl_IncrRefCount(objPtr);
+ (void) Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
+ Tcl_DecrRefCount(objPtr);
+
+ /*
+ * One possible failure mode above: exceeding a resource limit.
+ */
+
+ if (Tcl_LimitExceeded(interp)) {
+ return TCL_ERROR;
+ }
}
/*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9a0edf7..a3d6f48 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.277 2006/09/22 22:32:07 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.278 2006/09/30 17:56:47 msofer Exp $
*/
#ifndef _TCLINT
@@ -2554,6 +2554,8 @@ MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp* interp,
Tcl_Parse* parsePtr, struct CompileEnv* envPtr);
+MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp* interp,
Tcl_Parse* parsePtr, struct CompileEnv* envPtr);
MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp,
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 2069ea9..035de96 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.91 2006/05/15 16:07:47 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.92 2006/09/30 17:56:47 msofer Exp $
*/
#include "tclInt.h"
@@ -35,8 +35,6 @@ static void ProcBodyFree(Tcl_Obj *objPtr);
static int ProcessProcResultCode(Tcl_Interp *interp,
char *procName, int nameLen, int returnCode);
static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
-static int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr,
- struct CompileEnv *envPtr);
static int ProcCompileProc (Tcl_Interp *interp, Proc *procPtr,
Tcl_Obj *bodyPtr, Namespace *nsPtr,
CONST char *description, CONST char *procName,
@@ -1962,49 +1960,6 @@ ProcBodyFree(
}
/*
- *----------------------------------------------------------------------
- *
- * TclCompileNoOp --
- *
- * Function called to compile no-op's
- *
- * Results:
- * The return value is TCL_OK, indicating successful compilation.
- *
- * Side effects:
- * Instructions are added to envPtr to execute a no-op at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TclCompileNoOp(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr;
- int i;
- int savedStackDepth = envPtr->currStackDepth;
-
- tokenPtr = parsePtr->tokenPtr;
- for(i = 1; i < parsePtr->numWords; i++) {
- tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
- envPtr->currStackDepth = savedStackDepth;
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
- envPtr);
- TclEmitOpcode(INST_POP, envPtr);
- }
- }
- envPtr->currStackDepth = savedStackDepth;
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
- return TCL_OK;
-}
-
-/*
* LAMBDA and APPLY implementation. [TIP#194]
*/