Simplification+comments for ensemble dispatch engine

1 files changed, 175 insertions, 128 deletions

diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 7d9c2b4..7344a53 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.155 2007/11/16 14:11:52 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.156 2007/11/18 21:22:55 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -57,10 +57,10 @@ static Tcl_ThreadDataKey dataKey;
 typedef struct ResolvedNsName {
     Namespace *nsPtr;          /* A cached pointer to the Namespace that the
                                 * name resolved to. */
-    Namespace *refNsPtr;       /* Points to the namespace context in which
-                                * the name was resolved.  NULL if the name
-                                * is fully qualified and thus the resolution
-                                * does not depend on the context. */
+    Namespace *refNsPtr;       /* Points to the namespace context in which the
+                                * name was resolved. NULL if the name is fully
+                                * qualified and thus the resolution does not
+                                * depend on the context. */
     int refCount;		/* Reference count: 1 for each nsName object
 				 * that has a pointer to this ResolvedNsName
 				 * structure as its internal rep. This
@@ -380,15 +380,16 @@ Tcl_PushCallFrame(
 	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
     } else {
 	nsPtr = (Namespace *) namespacePtr;
+
 	/*
-	 * TODO: Examine whether it would be better to guard based
-	 * on NS_DYING or NS_KILLED.  It appears that these are not
-	 * tested because they can be set in a global interp that
-	 * has been [namespace delete]d, but which never really
-	 * completely goes away because of lingering global things
-	 * like ::errorInfo and [::unknown] and hidden commands.
+	 * TODO: Examine whether it would be better to guard based on NS_DYING
+	 * or NS_KILLED. It appears that these are not tested because they can
+	 * be set in a global interp that has been [namespace delete]d, but
+	 * which never really completely goes away because of lingering global
+	 * things like ::errorInfo and [::unknown] and hidden commands.
 	 * Review of those designs might permit stricter checking here.
 	 */
+
 	if (nsPtr->flags & NS_DEAD) {
 	    Tcl_Panic("Trying to push call frame for dead namespace");
 	    /*NOTREACHED*/
@@ -1499,6 +1500,7 @@ Tcl_Import(
     if (importNsPtr == NULL) {
 	Tcl_AppendResult(interp, "unknown namespace in import pattern \"",
 		pattern, "\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
 	return TCL_ERROR;
     }
     if (importNsPtr == nsPtr) {
@@ -1739,6 +1741,7 @@ Tcl_ForgetImport(
 	Tcl_AppendResult(interp,
 		"unknown namespace in namespace forget pattern \"",
 		pattern, "\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
 	return TCL_ERROR;
     }
 
@@ -2311,6 +2314,7 @@ Tcl_FindNamespace(
     } else if (flags & TCL_LEAVE_ERR_MSG) {
 	Tcl_ResetResult(interp);
 	Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
     }
     return NULL;
 }
@@ -2496,6 +2500,7 @@ Tcl_FindCommand(
     if (flags & TCL_LEAVE_ERR_MSG) {
 	Tcl_ResetResult(interp);
 	Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL);
     }
     return (Tcl_Command) NULL;
 }
@@ -2665,6 +2670,7 @@ TclGetNamespaceFromObj(
 {
     if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) {
 	const char *name = TclGetString(objPtr);
+
 	if ((name[0] == ':') && (name[1] == ':')) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		    "namespace \"%s\" not found", name));
@@ -2675,6 +2681,7 @@ TclGetNamespaceFromObj(
 		    "namespace \"%s\" not found in \"%s\"", name,
 		    Tcl_GetStringResult(interp)));
 	}
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
 	return TCL_ERROR;
     }
     return TCL_OK;
@@ -3160,6 +3167,8 @@ NamespaceDeleteCmd(
 	    Tcl_AppendResult(interp, "unknown namespace \"",
 		    TclGetString(objv[i]),
 		    "\" in namespace delete command", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE",
+		    TclGetString(objv[i]), NULL);
 	    return TCL_ERROR;
 	}
     }
@@ -3782,6 +3791,8 @@ NamespaceOriginCmd(
     if (command == (Tcl_Command) NULL) {
 	Tcl_AppendResult(interp, "invalid command name \"",
 		TclGetString(objv[2]), "\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
+		TclGetString(objv[2]), NULL);
 	return TCL_ERROR;
     }
     origCommand = TclGetOriginalCommand(command);
@@ -4668,34 +4679,33 @@ SetNsNameFromAny(
      * that holds a reference to it.
      */
 
-    if ((nsPtr != NULL) && !(nsPtr->flags & NS_DYING)) {
-	nsPtr->refCount++;
-	resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
-	resNamePtr->nsPtr = nsPtr;
-	if ((name[0] == ':') && (name[1] == ':')) {
-	    resNamePtr->refNsPtr = NULL;
-	} else {
-	    resNamePtr->refNsPtr =
-		    (Namespace *) Tcl_GetCurrentNamespace(interp);
-	}
-	resNamePtr->refCount = 1;
-	TclFreeIntRep(objPtr);
-	objPtr->internalRep.twoPtrValue.ptr1 = (void *) resNamePtr;
-	objPtr->typePtr = &nsNameType;
-	return TCL_OK;
-     } else {
+    if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
+	/*
+	 * Our failed lookup proves any previously cached nsName intrep is no
+	 * longer valid. Get rid of it so we no longer waste memory storing
+	 * it, nor time determining its invalidity again and again.
+	 */
+
 	if (objPtr->typePtr == &nsNameType) {
-	    /*
-	     * Our failed lookup proves any previously cached nsName
-	     * intrep is no longer valid.  Get rid of it so we no longer
-	     * waste memory storing it, nor time determining its invalidity
-	     * again and again.
-	     */
 	    TclFreeIntRep(objPtr);
 	    objPtr->typePtr = NULL;
 	}
 	return TCL_ERROR;
     }
+
+    nsPtr->refCount++;
+    resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
+    resNamePtr->nsPtr = nsPtr;
+    if ((name[0] == ':') && (name[1] == ':')) {
+	resNamePtr->refNsPtr = NULL;
+    } else {
+	resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+    }
+    resNamePtr->refCount = 1;
+    TclFreeIntRep(objPtr);
+    objPtr->internalRep.twoPtrValue.ptr1 = (void *) resNamePtr;
+    objPtr->typePtr = &nsNameType;
+    return TCL_OK;
 }
 
 /*
@@ -5822,6 +5832,8 @@ Tcl_FindEnsemble(
 	    if (flags & TCL_LEAVE_ERR_MSG) {
 		Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
 			"\" is not an ensemble command", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
+			TclGetString(cmdNameObj), NULL);
 	    }
 	    return NULL;
 	}
@@ -5914,89 +5926,7 @@ NsEnsembleImplementationCmd(
     }
 
   restartEnsembleParse:
-    if (!(ensemblePtr->nsPtr->flags & NS_DYING)) {
-	if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
-	    /*
-	     * Table of subcommands is still valid; therefore there might be a
-	     * valid cache of discovered information which we can reuse. Do
-	     * the check here, and if we're still valid, we can jump straight
-	     * to the part where we do the invocation of the subcommand.
-	     */
-
-	    if (objv[1]->typePtr == &tclEnsembleCmdType) {
-		EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
-			objv[1]->internalRep.otherValuePtr;
-		if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
-			ensembleCmd->epoch == ensemblePtr->epoch &&
-			ensembleCmd->token == ensemblePtr->token) {
-		    Interp *iPtr;
-		    int isRootEnsemble;
-		    Tcl_Obj *copyObj;
-
-		    prefixObj = ensembleCmd->realPrefixObj;
-		    Tcl_IncrRefCount(prefixObj);
-
-	        runResultingSubcommand:
-		    /*
-		     * Do the real work of execution of the subcommand by
-		     * building an array of objects (note that this is
-		     * potentially not the same length as the number of
-		     * arguments to this ensemble command), populating it and
-		     * then feeding it back through the main command-lookup
-		     * engine. In theory, we could look up the command in the
-		     * namespace ourselves, as we already have the namespace
-		     * in which it is guaranteed to exist, but we don't do
-		     * that (the cacheing of the command object used should
-		     * help with that.)
-		     */
-
-		    iPtr = (Interp *) interp;
-		    isRootEnsemble =
-			    (iPtr->ensembleRewrite.sourceObjs == NULL);
-		    copyObj = TclListObjCopy(NULL, prefixObj);
-
-		    TclListObjGetElements(NULL, copyObj, &prefixObjc,
-			    &prefixObjv);
-		    if (isRootEnsemble) {
-			iPtr->ensembleRewrite.sourceObjs = objv;
-			iPtr->ensembleRewrite.numRemovedObjs = 2;
-			iPtr->ensembleRewrite.numInsertedObjs = prefixObjc;
-		    } else {
-			int ni = iPtr->ensembleRewrite.numInsertedObjs;
-
-			if (ni < 2) {
-			    iPtr->ensembleRewrite.numRemovedObjs += 2 - ni;
-			    iPtr->ensembleRewrite.numInsertedObjs +=
-				    prefixObjc - 1;
-			} else {
-			    iPtr->ensembleRewrite.numInsertedObjs +=
-				    prefixObjc - 2;
-			}
-		    }
-		    tempObjv = (Tcl_Obj **) TclStackAlloc(interp,
-			    (int) sizeof(Tcl_Obj*) * (objc - 2 + prefixObjc));
-		    memcpy(tempObjv, prefixObjv,
-			    sizeof(Tcl_Obj *) * prefixObjc);
-		    memcpy(tempObjv+prefixObjc, objv+2,
-			    sizeof(Tcl_Obj *) * (objc-2));
-		    result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv,
-			    TCL_EVAL_INVOKE);
-		    Tcl_DecrRefCount(copyObj);
-		    Tcl_DecrRefCount(prefixObj);
-		    TclStackFree(interp, tempObjv);
-		    if (isRootEnsemble) {
-			iPtr->ensembleRewrite.sourceObjs = NULL;
-			iPtr->ensembleRewrite.numRemovedObjs = 0;
-			iPtr->ensembleRewrite.numInsertedObjs = 0;
-		    }
-		    return result;
-		}
-	    }
-	} else {
-	    BuildEnsembleConfig(ensemblePtr);
-	    ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
-	}
-    } else {
+    if (ensemblePtr->nsPtr->flags & NS_DYING) {
 	/*
 	 * Don't know how we got here, but make things give up quickly.
 	 */
@@ -6009,6 +5939,36 @@ NsEnsembleImplementationCmd(
     }
 
     /*
+     * Determine if the table of subcommands is right. If so, we can just look
+     * up in there and go straight to dispatch.
+     */
+
+    if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
+	/*
+	 * Table of subcommands is still valid; therefore there might be a
+	 * valid cache of discovered information which we can reuse. Do the
+	 * check here, and if we're still valid, we can jump straight to the
+	 * part where we do the invocation of the subcommand.
+	 */
+
+	if (objv[1]->typePtr == &tclEnsembleCmdType) {
+	    EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
+		    objv[1]->internalRep.otherValuePtr;
+
+	    if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
+		    ensembleCmd->epoch == ensemblePtr->epoch &&
+		    ensembleCmd->token == ensemblePtr->token) {
+		prefixObj = ensembleCmd->realPrefixObj;
+		Tcl_IncrRefCount(prefixObj);
+		goto runResultingSubcommand;
+	    }
+	}
+    } else {
+	BuildEnsembleConfig(ensemblePtr);
+	ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
+    }
+
+    /*
      * Look in the hashtable for the subcommand name; this is the fastest way
      * of all.
      */
@@ -6024,9 +5984,13 @@ NsEnsembleImplementationCmd(
 	 */
 
 	MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
-	Tcl_IncrRefCount(prefixObj);
-	goto runResultingSubcommand;
-    } else if (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX) {
+    } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
+	/*
+	 * Could not map, no prefixing, go to unknown/error handling.
+	 */
+
+	goto unknownOrAmbiguousSubcommand;
+    } else {
 	/*
 	 * If we've not already confirmed the command with the hash as part of
 	 * building our export table, we need to scan the sorted array for
@@ -6046,6 +6010,7 @@ NsEnsembleImplementationCmd(
 	    register int cmp = strncmp(subcmdName,
 		    ensemblePtr->subcommandArrayPtr[i],
 		    (unsigned) stringLength);
+
 	    if (cmp == 0) {
 		if (fullName != NULL) {
 		    /*
@@ -6087,10 +6052,88 @@ NsEnsembleImplementationCmd(
 	 */
 
 	MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
-	Tcl_IncrRefCount(prefixObj);
-	goto runResultingSubcommand;
     }
 
+    Tcl_IncrRefCount(prefixObj);
+  runResultingSubcommand:
+
+    /*
+     * Do the real work of execution of the subcommand by building an array of
+     * objects (note that this is potentially not the same length as the
+     * number of arguments to this ensemble command), populating it and then
+     * feeding it back through the main command-lookup engine. In theory, we
+     * could look up the command in the namespace ourselves, as we already
+     * have the namespace in which it is guaranteed to exist, but we don't do
+     * that (the cacheing of the command object used should help with that.)
+     */
+
+    {
+	Interp *iPtr = (Interp *) interp;
+	int isRootEnsemble;
+	Tcl_Obj *copyObj;
+
+	/*
+	 * Get the prefix that we're rewriting to. To do this we need to
+	 * ensure that the internal representation of the list does not change
+	 * so that we can safely keep the internal representations of the
+	 * elements in the list.
+	 */
+
+	copyObj = TclListObjCopy(NULL, prefixObj);
+	TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
+
+	/*
+	 * Record what arguments the script sent in so that things like
+	 * Tcl_WrongNumArgs can give the correct error message.
+	 */
+
+	isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+	if (isRootEnsemble) {
+	    iPtr->ensembleRewrite.sourceObjs = objv;
+	    iPtr->ensembleRewrite.numRemovedObjs = 2;
+	    iPtr->ensembleRewrite.numInsertedObjs = prefixObjc;
+	} else {
+	    int ni = iPtr->ensembleRewrite.numInsertedObjs;
+
+	    if (ni < 2) {
+		iPtr->ensembleRewrite.numRemovedObjs += 2 - ni;
+		iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1;
+	    } else {
+		iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2;
+	    }
+	}
+
+	/*
+	 * Allocate a workspace and build the list of arguments to pass to the
+	 * target command in it.
+	 */
+
+	tempObjv = (Tcl_Obj **) TclStackAlloc(interp,
+		(int) sizeof(Tcl_Obj *) * (objc - 2 + prefixObjc));
+	memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
+	memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2));
+
+	/*
+	 * Hand off to the target command.
+	 */
+
+	result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv,
+		TCL_EVAL_INVOKE);
+
+	/*
+	 * Clean up.
+	 */
+
+	TclStackFree(interp, tempObjv);
+	Tcl_DecrRefCount(copyObj);
+	if (isRootEnsemble) {
+	    iPtr->ensembleRewrite.sourceObjs = NULL;
+	    iPtr->ensembleRewrite.numRemovedObjs = 0;
+	    iPtr->ensembleRewrite.numInsertedObjs = 0;
+	}
+    }
+    Tcl_DecrRefCount(prefixObj);
+    return result;
 
   unknownOrAmbiguousSubcommand:
     /*
@@ -6154,6 +6197,8 @@ NsEnsembleImplementationCmd(
 	}
 	if (!Tcl_InterpDeleted(interp)) {
 	    if (result != TCL_ERROR) {
+		char buf[TCL_INTEGER_SPACE];
+
 		Tcl_ResetResult(interp);
 		Tcl_SetResult(interp,
 			"unknown subcommand handler returned bad code: ",
@@ -6168,19 +6213,16 @@ NsEnsembleImplementationCmd(
 		case TCL_CONTINUE:
 		    Tcl_AppendResult(interp, "continue", NULL);
 		    break;
-		default: {
-		    char buf[TCL_INTEGER_SPACE];
-
+		default:
 		    sprintf(buf, "%d", result);
 		    Tcl_AppendResult(interp, buf, NULL);
 		}
-		}
 		Tcl_AddErrorInfo(interp, "\n    result of "
 			"ensemble unknown subcommand handler: ");
 		Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
 	    } else {
-		Tcl_AddErrorInfo(interp, "\n    (ensemble unknown "
-			"subcommand handler)");
+		Tcl_AddErrorInfo(interp,
+			"\n    (ensemble unknown subcommand handler)");
 	    }
 	}
 	Tcl_DecrRefCount(unknownCmd);
@@ -6189,7 +6231,7 @@ NsEnsembleImplementationCmd(
     }
 
     /*
-     * Cannot determine what subcommand to hand off to, so generate a
+     * We cannot determine what subcommand to hand off to, so generate a
      * (standard) failure message. Note the one odd case compared with
      * standard ensemble-like command, which is where a namespace has no
      * exported commands at all...
@@ -6200,6 +6242,8 @@ NsEnsembleImplementationCmd(
 	Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]),
 		"\": namespace ", ensemblePtr->nsPtr->fullName,
 		" does not export any commands", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
+		TclGetString(objv[1]), NULL);
 	return TCL_ERROR;
     }
     Tcl_AppendResult(interp, "unknown ",
@@ -6209,6 +6253,7 @@ NsEnsembleImplementationCmd(
 	Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL);
     } else {
 	int i;
+
 	for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
 	    Tcl_AppendResult(interp,
 		    ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
@@ -6216,6 +6261,8 @@ NsEnsembleImplementationCmd(
 	Tcl_AppendResult(interp, "or ",
 		ensemblePtr->subcommandArrayPtr[i], NULL);
     }
+    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
+	    TclGetString(objv[1]), NULL);
     return TCL_ERROR;
 }