Attachment "history.patch" to
ticket [1190441fff]
added by
msofer
2006-10-01 00:59:43.
Index: generic/tclCompile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.c,v
retrieving revision 1.97
diff -u -r1.97 tclCompile.c
--- generic/tclCompile.c 29 Aug 2006 06:28:38 -0000 1.97
+++ generic/tclCompile.c 30 Sep 2006 17:42:50 -0000
@@ -1636,6 +1636,51 @@
/*
*----------------------------------------------------------------------
*
+ * 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
Index: generic/tclHistory.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclHistory.c,v
retrieving revision 1.8
diff -u -r1.8 tclHistory.c
--- generic/tclHistory.c 18 Oct 2005 14:34:41 -0000 1.8
+++ generic/tclHistory.c 30 Sep 2006 17:42:50 -0000
@@ -112,29 +112,44 @@
* 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;
-
- objPtr = Tcl_NewListObj(3, list);
- Tcl_IncrRefCount(objPtr);
- (void) Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
- Tcl_DecrRefCount(objPtr);
+ result = Tcl_GetCommandInfo(interp, "history", &info);
- /*
- * One possible failure mode above: exceeding a resource limit.
- */
+ if (result && (info.objProc == TclObjInterpProc)) {
+ Proc *procPtr = (Proc *)(info.objClientData);
+ call = (procPtr->cmdPtr->compileProc != TclCompileNoOp);
+ }
+
+ 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;
+ }
}
/*
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.277
diff -u -r1.277 tclInt.h
--- generic/tclInt.h 22 Sep 2006 22:32:07 -0000 1.277
+++ generic/tclInt.h 30 Sep 2006 17:42:51 -0000
@@ -2554,6 +2554,8 @@
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,
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.91
diff -u -r1.91 tclProc.c
--- generic/tclProc.c 15 May 2006 16:07:47 -0000 1.91
+++ generic/tclProc.c 30 Sep 2006 17:42:53 -0000
@@ -35,8 +35,6 @@
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 @@
}
/*
- *----------------------------------------------------------------------
- *
- * 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]
*/
