Implementation of almost all of oo::configurable in C, for better performance.

1 files changed, 97 insertions, 75 deletions

diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index a3cccc7..1506a34 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -56,7 +56,7 @@ FinalizeConstruction(
     Tcl_Interp *interp,
     int result)
 {
-    Object *oPtr = (Object *)data[0];
+    Object *oPtr = (Object *) data[0];
 
     if (result != TCL_OK) {
 	return result;
@@ -87,11 +87,11 @@ TclOO_Class_Constructor(
     Tcl_Obj **invoke, *nameObj;
 
     size_t skip = Tcl_ObjectContextSkippedArgs(context);
-    if ((size_t)objc > skip + 1) {
+    if ((size_t) objc > skip + 1) {
 	Tcl_WrongNumArgs(interp, skip, objv,
 		"?definitionScript?");
 	return TCL_ERROR;
-    } else if ((size_t)objc == skip) {
+    } else if ((size_t) objc == skip) {
 	return TCL_OK;
     }
 
@@ -100,17 +100,17 @@ TclOO_Class_Constructor(
      * here (and the class definition delegate doesn't run any constructors).
      */
 
-    nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
-    Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
+    nameObj = Tcl_ObjPrintf("%s:: oo ::delegate",
+	    oPtr->namespacePtr->fullName);
     Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
 	    TclGetString(nameObj), NULL, -1, NULL, -1);
-    Tcl_DecrRefCount(nameObj);
+    Tcl_BounceRefCount(nameObj);
 
     /*
      * Delegate to [oo::define] to do the work.
      */
 
-    invoke = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *));
+    invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
     invoke[0] = oPtr->fPtr->defineName;
     invoke[1] = TclOOObjectName(interp, oPtr);
     invoke[2] = objv[objc-1];
@@ -140,8 +140,8 @@ DecrRefsPostClassConstructor(
     Tcl_Interp *interp,
     int result)
 {
-    Tcl_Obj **invoke = (Tcl_Obj **)data[0];
-    Object *oPtr = (Object *)data[1];
+    Tcl_Obj **invoke = (Tcl_Obj **) data[0];
+    Object *oPtr = (Object *) data[1];
     Tcl_InterpState saved;
     int code;
 
@@ -156,7 +156,7 @@ DecrRefsPostClassConstructor(
     code = Tcl_EvalObjv(interp, 2, invoke, 0);
     TclDecrRefCount(invoke[0]);
     TclDecrRefCount(invoke[1]);
-    Tcl_Free(invoke);
+    TclStackFree(interp, invoke);
     if (code != TCL_OK) {
 	Tcl_DiscardInterpState(saved);
 	return code;
@@ -368,7 +368,7 @@ TclOO_Object_Destroy(
     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
     CallContext *contextPtr;
 
-    if (objc != (int)Tcl_ObjectContextSkippedArgs(context)) {
+    if (objc != (int) Tcl_ObjectContextSkippedArgs(context)) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 		NULL);
 	return TCL_ERROR;
@@ -398,7 +398,7 @@ AfterNRDestructor(
     Tcl_Interp *interp,
     int result)
 {
-    CallContext *contextPtr = (CallContext *)data[0];
+    CallContext *contextPtr = (CallContext *) data[0];
 
     if (contextPtr->oPtr->command) {
 	Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
@@ -433,7 +433,7 @@ TclOO_Object_Eval(
     Tcl_Obj *scriptPtr;
     CmdFrame *invoker;
 
-    if ((size_t)objc < skip + 1) {
+    if ((size_t) objc < skip + 1) {
 	Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?");
 	return TCL_ERROR;
     }
@@ -462,7 +462,7 @@ TclOO_Object_Eval(
      * object when it decrements its refcount after eval'ing it.
      */
 
-    if ((size_t)objc != skip+1) {
+    if ((size_t) objc != skip+1) {
 	scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip);
 	invoker = NULL;
     } else {
@@ -486,7 +486,7 @@ FinalizeEval(
     int result)
 {
     if (result == TCL_ERROR) {
-	Object *oPtr = (Object *)data[0];
+	Object *oPtr = (Object *) data[0];
 	const char *namePtr;
 
 	if (oPtr) {
@@ -544,7 +544,7 @@ TclOO_Object_Unknown(
      * name without an error).
      */
 
-    if ((size_t)objc < skip+1) {
+    if ((size_t) objc < skip + 1) {
 	Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
 	return TCL_ERROR;
     }
@@ -555,7 +555,7 @@ TclOO_Object_Unknown(
      */
 
     if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
-	CallContext *callerContext = (CallContext *)framePtr->clientData;
+	CallContext *callerContext = (CallContext *) framePtr->clientData;
 	Method *mPtr = callerContext->callPtr->chain[
 		    callerContext->index].mPtr;
 
@@ -609,7 +609,7 @@ TclOO_Object_Unknown(
 	Tcl_AppendToObj(errorMsg, " or ", -1);
     }
     Tcl_AppendToObj(errorMsg, methodNames[i], -1);
-    Tcl_Free((void *)methodNames);
+    Tcl_Free((void *) methodNames);
     Tcl_SetObjResult(interp, errorMsg);
     Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
 	    TclGetString(objv[skip]), (char *)NULL);
@@ -721,34 +721,21 @@ TclOO_Object_LinkVar(
 /*
  * ----------------------------------------------------------------------
  *
- * TclOO_Object_VarName --
+ * TclOOLookupObjectVar --
  *
- *	Implementation of the oo::object->varname method.
+ *	Look up a variable in an object. Tricky because of private variables.
  *
  * ----------------------------------------------------------------------
  */
-
-int
-TclOO_Object_VarName(
-    TCL_UNUSED(void *),
-    Tcl_Interp *interp,		/* Interpreter in which to create the object;
-				 * also used for error reporting. */
-    Tcl_ObjectContext context,	/* The object/call context. */
-    int objc,			/* Number of arguments. */
-    Tcl_Obj *const *objv)	/* The actual arguments. */
+Tcl_Var
+TclOOLookupObjectVar(
+    Tcl_Interp *interp,
+    Tcl_Object object,
+    Tcl_Obj *varName,
+    Tcl_Var *aryPtr)
 {
-    Var *varPtr, *aryVar;
-    Tcl_Obj *varNamePtr, *argPtr;
-    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
-    const char *arg;
-
-    if ((int)Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
-		"varName");
-	return TCL_ERROR;
-    }
-    argPtr = objv[objc-1];
-    arg = TclGetString(argPtr);
+    const char *arg = TclGetString(varName);
+    Tcl_Obj *varNamePtr;
 
     /*
      * Convert the variable name to fully-qualified form if it wasn't already.
@@ -760,10 +747,10 @@ TclOO_Object_VarName(
      */
 
     if (arg[0] == ':' && arg[1] == ':') {
-	varNamePtr = argPtr;
+	varNamePtr = varName;
     } else {
-	Tcl_Namespace *namespacePtr =
-		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
+	Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(object);
+	CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
 
 	/*
 	 * Private method handling. [TIP 500]
@@ -776,8 +763,8 @@ TclOO_Object_VarName(
 	 */
 
 	if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
-	    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
-	    CallContext *callerContext = (CallContext *)framePtr->clientData;
+	    Object *oPtr = (Object *) object;
+	    CallContext *callerContext = (CallContext *) framePtr->clientData;
 	    Method *mPtr = callerContext->callPtr->chain[
 		    callerContext->index].mPtr;
 	    PrivateVariableMapping *pvPtr;
@@ -785,9 +772,9 @@ TclOO_Object_VarName(
 
 	    if (mPtr->declaringObjectPtr == oPtr) {
 		FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
-		    if (!strcmp(TclGetString(pvPtr->variableObj),
-			    TclGetString(argPtr))) {
-			argPtr = pvPtr->fullNameObj;
+		    if (!TclStringCmp(pvPtr->variableObj, varName, 1, 0,
+			    TCL_INDEX_NONE)) {
+			varName = pvPtr->fullNameObj;
 			break;
 		    }
 		}
@@ -807,9 +794,9 @@ TclOO_Object_VarName(
 		}
 		if (isInstance) {
 		    FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
-			if (!strcmp(TclGetString(pvPtr->variableObj),
-				TclGetString(argPtr))) {
-			    argPtr = pvPtr->fullNameObj;
+			if (!TclStringCmp(pvPtr->variableObj, varName, 1, 0,
+				TCL_INDEX_NONE)) {
+			    varName = pvPtr->fullNameObj;
 			    break;
 			}
 		    }
@@ -817,23 +804,59 @@ TclOO_Object_VarName(
 	    }
 	}
 
-	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
-	Tcl_AppendToObj(varNamePtr, "::", 2);
-	Tcl_AppendObjToObj(varNamePtr, argPtr);
+	// The namespace isn't the global one; necessarily true for any object!
+	varNamePtr = Tcl_ObjPrintf("%s::%s",
+		namespacePtr->fullName, TclGetString(varName));
     }
     Tcl_IncrRefCount(varNamePtr);
-    varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
-	    TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
+    Tcl_Var var = (Tcl_Var) TclObjLookupVar(interp, varNamePtr, NULL,
+	    TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1,
+	    (Var **) aryPtr);
     Tcl_DecrRefCount(varNamePtr);
+    if (var == NULL) {
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (void *) NULL);
+    }
+    return var;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_VarName --
+ *
+ *	Implementation of the oo::object->varname method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_VarName(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    Tcl_Var varPtr, aryVar;
+    Tcl_Obj *varNamePtr;
+
+    if ((int) Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"varName");
+	return TCL_ERROR;
+    }
+
+    varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
+	    objv[objc - 1], &aryVar);
     if (varPtr == NULL) {
-	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (char *)NULL);
 	return TCL_ERROR;
     }
 
     /*
      * The variable reference must not disappear too soon. [Bug 74b6110204]
      */
-    TclSetVarNamespaceVar(varPtr);
+    TclSetVarNamespaceVar((Var *) varPtr);
 
     /*
      * Now that we've pinned down what variable we're really talking about
@@ -842,18 +865,16 @@ TclOO_Object_VarName(
 
     TclNewObj(varNamePtr);
     if (aryVar != NULL) {
-	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
+	Tcl_GetVariableFullName(interp, aryVar, varNamePtr);
 
 	/*
 	 * WARNING! This code pokes inside the implementation of hash tables!
 	 */
 
-	Tcl_AppendToObj(varNamePtr, "(", -1);
-	Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
-		varPtr)->entry.key.objPtr);
-	Tcl_AppendToObj(varNamePtr, ")", -1);
+	Tcl_AppendPrintfToObj(varNamePtr, "(%s)", Tcl_GetString(
+		((VarInHash *) varPtr)->entry.key.objPtr));
     } else {
-	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+	Tcl_GetVariableFullName(interp, varPtr, varNamePtr);
     }
     Tcl_SetObjResult(interp, varNamePtr);
     return TCL_OK;
@@ -895,7 +916,7 @@ TclOONextObjCmd(
 	Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
 	return TCL_ERROR;
     }
-    context = (Tcl_ObjectContext)framePtr->clientData;
+    context = (Tcl_ObjectContext) framePtr->clientData;
 
     /*
      * Invoke the (advanced) method call context in the caller context. Note
@@ -935,7 +956,7 @@ TclOONextToObjCmd(
 	Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
 	return TCL_ERROR;
     }
-    contextPtr = (CallContext *)framePtr->clientData;
+    contextPtr = (CallContext *) framePtr->clientData;
 
     /*
      * Sanity check the arguments; we need the first one to refer to a class.
@@ -949,7 +970,7 @@ TclOONextToObjCmd(
     if (object == NULL) {
 	return TCL_ERROR;
     }
-    classPtr = ((Object *)object)->classPtr;
+    classPtr = ((Object *) object)->classPtr;
     if (classPtr == NULL) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"\"%s\" is not a class", TclGetString(objv[1])));
@@ -964,7 +985,7 @@ TclOONextToObjCmd(
      */
 
     for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
-	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+	MInvoke *miPtr = &contextPtr->callPtr->chain[i];
 
 	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
 	    /*
@@ -995,7 +1016,7 @@ TclOONextToObjCmd(
     }
 
     for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) {
-	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+	MInvoke *miPtr = &contextPtr->callPtr->chain[i];
 
 	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -1020,9 +1041,9 @@ NextRestoreFrame(
     int result)
 {
     Interp *iPtr = (Interp *) interp;
-    CallContext *contextPtr = (CallContext *)data[1];
+    CallContext *contextPtr = (CallContext *) data[1];
 
-    iPtr->varFramePtr = (CallFrame *)data[0];
+    iPtr->varFramePtr = (CallFrame *) data[0];
     if (contextPtr != NULL) {
 	contextPtr->index = PTR2UINT(data[2]);
     }
@@ -1075,7 +1096,7 @@ TclOOSelfObjCmd(
 	return TCL_ERROR;
     }
 
-    contextPtr = (CallContext*)framePtr->clientData;
+    contextPtr = (CallContext *) framePtr->clientData;
 
     /*
      * Now we do "conventional" argument parsing for a while. Note that no
@@ -1130,7 +1151,7 @@ TclOOSelfObjCmd(
 	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL);
 	    return TCL_ERROR;
 	} else {
-	    struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
+	    MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
 	    Object *oPtr;
 	    const char *type;
 
@@ -1156,7 +1177,8 @@ TclOOSelfObjCmd(
 	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
 	    return TCL_ERROR;
 	} else {
-	    CallContext *callerPtr = (CallContext *)framePtr->callerVarPtr->clientData;
+	    CallContext *callerPtr = (CallContext *)
+		    framePtr->callerVarPtr->clientData;
 	    Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
 	    Object *declarerPtr;