* 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


FossilOrigin-Name: 639783a61c6753063dca371837538b907e0ddfbf

5 files changed, 90 insertions, 63 deletions

diff --git a/ChangeLog b/ChangeLog
index e809265..af0f7cb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2006-09-30  Miguel Sofer  <msofer@users.sf.net>
+
+	* 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 
+
 2006-09-28  Andreas Kupries  <andreask@activestate.com>
 
 	* generic/tclPkg.c (CompareVersions): Bugfix. Check string lengths
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]
  */