Fix for [Bug 582522] - aliases now fire execution traces on the target

command. Optimisation of alias invocation.

3 files changed, 81 insertions, 89 deletions

diff --git a/generic/tcl.h b/generic/tcl.h
index 4fc6592..d090013 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.136 2002/07/22 16:51:47 vincentdarley Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.137 2002/07/29 00:25:49 msofer Exp $
  */
 
 #ifndef _TCL
@@ -984,6 +984,7 @@ typedef struct Tcl_DString {
 #define TCL_NO_EVAL		0x10000
 #define TCL_EVAL_GLOBAL		0x20000
 #define TCL_EVAL_DIRECT		0x40000
+#define TCL_EVAL_NO_TRACEBACK	0x80000
 
 /*
  * Special freeProc values that may be passed to Tcl_SetResult (see
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a2d1dcd..ef2a29c 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.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: tclBasic.c,v 1.65 2002/07/19 12:31:09 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.66 2002/07/29 00:25:49 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -2876,7 +2876,7 @@ TclInterpReady(interp)
     if (((iPtr->numLevels) >= iPtr->maxNestingDepth) 
 	    || (TclpCheckStackSpace() == 0)) {
 	Tcl_AppendToObj(Tcl_GetObjResult(interp),
-		"too many nested calls to Tcl_Eval (infinite loop?)", -1); 
+		"too many nested evaluations (infinite loop?)", -1); 
 	return TCL_ERROR;
     }
 
@@ -3101,8 +3101,8 @@ Tcl_EvalObjv(interp, objc, objv, flags)
 				 * 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 is currently
-				 * supported. */
+				 * TCL_EVAL_GLOBAL and TCL_EVAL_NO_TRACEBACK
+				 * are  currently supported. */
 {
     Interp *iPtr = (Interp *)interp;
     Trace *tracePtr;
@@ -3158,7 +3158,7 @@ Tcl_EvalObjv(interp, objc, objv, flags)
 	}
     }
 	    
-    if (code == TCL_ERROR) {
+    if ((code == TCL_ERROR) && !(flags & TCL_EVAL_NO_TRACEBACK)) {
 
 	/* 
 	 * If there was an error, a command string will be needed for the 
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index c522607..65c41d9 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -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: tclInterp.c,v 1.12 2002/03/07 20:17:22 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.13 2002/07/29 00:25:49 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -35,12 +35,6 @@ typedef struct Alias {
     Tcl_Obj *namePtr;		/* Name of alias command in slave interp. */
     Tcl_Interp *targetInterp;	/* Interp in which target command will be
 				 * invoked. */
-    Tcl_Obj *prefixPtr;		/* Tcl list making up the prefix of the
-				 * target command to be invoked in the target
-				 * interpreter.  Additional arguments
-				 * specified when calling the alias in the
-				 * slave interp will be appended to the prefix
-				 * before the command is invoked. */
     Tcl_Command slaveCmd;	/* Source command in slave interpreter,
 				 * bound to command that invokes the target
 				 * command in the target interpreter. */
@@ -56,6 +50,16 @@ typedef struct Alias {
                                  * redirecting to it. Random access to this
                                  * hash table is never required - we are using
                                  * a hash table only for convenience. */
+    unsigned int objc;          /* Count of Tcl_Obj in the prefix of the
+				 * target command to be invoked in the
+				 * target interpreter. Additional arguments
+				 * specified when calling the alias in the
+				 * slave interp will be appended to the prefix
+				 * before the command is invoked. */
+    Tcl_Obj *objPtr;            /* The first actual prefix object - the target
+				 * command name; this has to be at the end of the 
+				 * structure, which will be extended to accomodate 
+				 * the remaining objects in the prefix. */
 } Alias;
 
 /*
@@ -945,7 +949,8 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
 	return TCL_ERROR;
     }
     aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
-    Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);
+    objc = aliasPtr->objc;
+    objv = &aliasPtr->objPtr;
 
     if (targetInterpPtr != NULL) {
 	*targetInterpPtr = aliasPtr->targetInterp;
@@ -1005,7 +1010,8 @@ Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
         return TCL_ERROR;
     }
     aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
-    Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);
+    objc = aliasPtr->objc;
+    objv = &aliasPtr->objPtr;
 
     if (targetInterpPtr != (Tcl_Interp **) NULL) {
         *targetInterpPtr = aliasPtr->targetInterp;
@@ -1075,17 +1081,16 @@ TclPreventAliasLoop(interp, cmdInterp, cmd)
     aliasPtr = (Alias *) cmdPtr->objClientData;
     nextAliasPtr = aliasPtr;
     while (1) {
-	int objc;
-	Tcl_Obj **objv;
+	Tcl_Obj *cmdNamePtr;
 
         /*
          * If the target of the next alias in the chain is the same as
          * the source alias, we have a loop.
 	 */
 
-	Tcl_ListObjGetElements(NULL, nextAliasPtr->prefixPtr, &objc, &objv);
+	cmdNamePtr = nextAliasPtr->objPtr;
 	aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
-                Tcl_GetString(objv[0]),
+                Tcl_GetString(cmdNamePtr),
 		Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
 		/*flags*/ 0);
         if (aliasCmd == (Tcl_Command) NULL) {
@@ -1151,14 +1156,24 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
     Target *targetPtr;
     Slave *slavePtr;
     Master *masterPtr;
+    int i;
+    Tcl_Obj **prefv;
 
-    aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias));
+    aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) 
+            + objc * sizeof(Tcl_Obj *)));
     aliasPtr->namePtr		= namePtr;
     Tcl_IncrRefCount(aliasPtr->namePtr);
     aliasPtr->targetInterp	= masterInterp;
-    aliasPtr->prefixPtr		= Tcl_NewListObj(1, &targetNamePtr);
-    Tcl_ListObjReplace(NULL, aliasPtr->prefixPtr, 1, 0, objc, objv);
-    Tcl_IncrRefCount(aliasPtr->prefixPtr);
+
+    aliasPtr->objc = objc + 1;
+    prefv = &aliasPtr->objPtr;
+
+    *prefv = targetNamePtr;
+    Tcl_IncrRefCount(targetNamePtr);
+    for (i = 0; i < objc; i++) {
+	*(++prefv) = objv[i];
+	Tcl_IncrRefCount(objv[i]);
+    }
 
     aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
 	    Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
@@ -1175,7 +1190,9 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
 	Command *cmdPtr;
 	
 	Tcl_DecrRefCount(aliasPtr->namePtr);
-	Tcl_DecrRefCount(aliasPtr->prefixPtr);
+	for (i = 0; i < objc; i++) {
+	    Tcl_DecrRefCount(objv[i]);
+	}
 	
         cmdPtr = (Command *) aliasPtr->slaveCmd;
         cmdPtr->clientData = NULL;
@@ -1264,7 +1281,7 @@ static int
 AliasDelete(interp, slaveInterp, namePtr)
     Tcl_Interp *interp;		/* Interpreter for result & errors. */
     Tcl_Interp *slaveInterp;	/* Interpreter containing alias. */
-    Tcl_Obj *namePtr;		/* Name of alias to describe. */
+    Tcl_Obj *namePtr;		/* Name of alias to delete. */
 {
     Slave *slavePtr;
     Alias *aliasPtr;
@@ -1316,6 +1333,7 @@ AliasDescribe(interp, slaveInterp, namePtr)
     Slave *slavePtr;
     Tcl_HashEntry *hPtr;
     Alias *aliasPtr;	
+    Tcl_Obj *prefixPtr;
 
     /*
      * If the alias has been renamed in the slave, the master can still use
@@ -1329,7 +1347,8 @@ AliasDescribe(interp, slaveInterp, namePtr)
         return TCL_OK;
     }
     aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
-    Tcl_SetObjResult(interp, aliasPtr->prefixPtr);
+    prefixPtr = Tcl_NewListObj((int) aliasPtr->objc, &aliasPtr->objPtr);
+    Tcl_SetObjResult(interp, prefixPtr);
     return TCL_OK;
 }
 
@@ -1400,84 +1419,51 @@ AliasObjCmd(clientData, interp, objc, objv)
     int objc;			/* Number of arguments. */
     Tcl_Obj *CONST objv[];	/* Argument vector. */	
 {
+#define ALIAS_CMDV_PREALLOC 10
     Tcl_Interp *targetInterp;	
     Alias *aliasPtr;		
     int result, prefc, cmdc;
-    Tcl_Obj *cmdPtr;
     Tcl_Obj **prefv, **cmdv;
-    
+    Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
     aliasPtr = (Alias *) clientData;
     targetInterp = aliasPtr->targetInterp;
 
-    Tcl_Preserve((ClientData) targetInterp);
-
-    ((Interp *) targetInterp)->numLevels++;
-
-    Tcl_ResetResult(targetInterp);
-    Tcl_AllowExceptions(targetInterp);
-
-    /*
-     * Check depth of nested calls with AliasObjCmd: if this gets too large,
-     * it's probably because of an infinite loop somewhere.
-     */
-
-    if (((Interp *) targetInterp)->numLevels >
-	    ((Interp *) targetInterp)->maxNestingDepth) {
-	Tcl_AppendToObj(Tcl_GetObjResult(targetInterp),
-		"too many nested calls to AliasObjCmd (infinite loop using alias?)", -1);
-	result = TCL_ERROR;
-	goto done;
-    }
-
     /*
      * Append the arguments to the command prefix and invoke the command
      * in the target interp's global namespace.
      */
      
-    Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &prefc, &prefv);
-    cmdPtr = Tcl_NewListObj(prefc, prefv);
-    Tcl_ListObjReplace(NULL, cmdPtr, prefc, 0, objc - 1, objv + 1);
-    Tcl_ListObjGetElements(NULL, cmdPtr, &cmdc, &cmdv);
-    result = TclObjInvoke(targetInterp, cmdc, cmdv,
-	    TCL_INVOKE_NO_TRACEBACK);
-    Tcl_DecrRefCount(cmdPtr);
+    prefc = aliasPtr->objc;
+    prefv = &aliasPtr->objPtr;
+    cmdc = prefc + objc - 1;
+    if (cmdc <= ALIAS_CMDV_PREALLOC) {
+	cmdv = cmdArr;
+    } else {
+	cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
+    }
 
-    /*
-     * Check if we are at the bottom of the stack for the target interpreter.
-     * If so, check for special return codes.
-     */
-    
-    if (((Interp *) targetInterp)->numLevels == 0) {
-	if (result == TCL_RETURN) {
-	    result = TclUpdateReturnInfo((Interp *) targetInterp);
-	}
-	if ((result != TCL_OK) && (result != TCL_ERROR)) {
-	    Tcl_ResetResult(targetInterp);
-	    if (result == TCL_BREAK) {
-                Tcl_SetObjResult(targetInterp,
-                        Tcl_NewStringObj("invoked \"break\" outside of a loop",
-                                -1));
-	    } else if (result == TCL_CONTINUE) {
-                Tcl_SetObjResult(targetInterp,
-                        Tcl_NewStringObj(
-                            "invoked \"continue\" outside of a loop",
-                            -1));
-	    } else {
-                char buf[32 + TCL_INTEGER_SPACE];
-
-                sprintf(buf, "command returned bad code: %d", result);
-                Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1));
-	    }
-	    result = TCL_ERROR;
-	}
+    prefv = &aliasPtr->objPtr;
+    memcpy((VOID *) cmdv, (VOID *) prefv, 
+            (size_t) (prefc * sizeof(Tcl_Obj *)));
+    memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), 
+	    (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
+
+    Tcl_ResetResult(targetInterp);
+
+    if (targetInterp != interp) {
+	Tcl_Preserve((ClientData) targetInterp);
+	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_NO_TRACEBACK);
+	TclTransferResult(targetInterp, result, interp);	
+	Tcl_Release((ClientData) targetInterp);
+    } else {
+	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_NO_TRACEBACK);
     }
-    done:
-    ((Interp *) targetInterp)->numLevels--;
-    
-    TclTransferResult(targetInterp, result, interp);
 
-    Tcl_Release((ClientData) targetInterp);
+    if (cmdv != cmdArr) {
+	ckfree((char *) cmdv);
+    }
     return result;        
+#undef ALIAS_CMDV_PREALLOC
 }
 
 /*
@@ -1504,11 +1490,16 @@ AliasObjCmdDeleteProc(clientData)
 {
     Alias *aliasPtr;		
     Target *targetPtr;		
+    int i;
+    Tcl_Obj **objv;
 
     aliasPtr = (Alias *) clientData;
     
     Tcl_DecrRefCount(aliasPtr->namePtr);
-    Tcl_DecrRefCount(aliasPtr->prefixPtr);
+    objv = &aliasPtr->objPtr;
+    for (i = 0; i < aliasPtr->objc; i++) {
+	Tcl_DecrRefCount(objv[i]);
+    }
     Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
 
     targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);