merge trunkdkf_alias_encoding

1 files changed, 131 insertions, 109 deletions

diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 329f0a4..3637ede 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -19,6 +19,8 @@
 static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
 static int		AfterNRDestructor(ClientData data[],
 			    Tcl_Interp *interp, int result);
+static int		DecrRefsPostClassConstructor(ClientData data[],
+			    Tcl_Interp *interp, int result);
 static int		FinalizeConstruction(ClientData data[],
 			    Tcl_Interp *interp, int result);
 static int		FinalizeEval(ClientData data[],
@@ -70,6 +72,74 @@ FinalizeConstruction(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOO_Class_Constructor --
+ *
+ *	Implementation for oo::class constructor.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_Constructor(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    Tcl_Obj *invoke[3];
+
+    if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"?definitionScript?");
+	return TCL_ERROR;
+    } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
+	return TCL_OK;
+    }
+
+    /*
+     * Delegate to [oo::define] to do the work.
+     */
+
+    invoke[0] = oPtr->fPtr->defineName;
+    invoke[1] = TclOOObjectName(interp, oPtr);
+    invoke[2] = objv[objc-1];
+
+    /*
+     * Must add references or errors in configuration script will cause
+     * trouble.
+     */
+
+    Tcl_IncrRefCount(invoke[0]);
+    Tcl_IncrRefCount(invoke[1]);
+    Tcl_IncrRefCount(invoke[2]);
+    TclNRAddCallback(interp, DecrRefsPostClassConstructor,
+	    invoke[0], invoke[1], invoke[2], NULL);
+
+    /*
+     * Tricky point: do not want the extra reported level in the Tcl stack
+     * trace, so use TCL_EVAL_NOERR.
+     */
+
+    return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
+}
+
+static int
+DecrRefsPostClassConstructor(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    TclDecrRefCount((Tcl_Obj *) data[0]);
+    TclDecrRefCount((Tcl_Obj *) data[1]);
+    TclDecrRefCount((Tcl_Obj *) data[2]);
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOO_Class_Create --
  *
  *	Implementation for oo::class->create method.
@@ -98,8 +168,8 @@ TclOO_Class_Create(
     if (oPtr->classPtr == NULL) {
 	Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
 
-	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
-		"\" is not a class", NULL);
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"object \"%s\" is not a class", TclGetString(cmdnameObj)));
 	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 	return TCL_ERROR;
     }
@@ -116,7 +186,8 @@ TclOO_Class_Create(
     objName = Tcl_GetStringFromObj(
 	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
     if (len == 0) {
-	Tcl_AppendResult(interp, "object name must not be empty", NULL);
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"object name must not be empty", -1));
 	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
 	return TCL_ERROR;
     }
@@ -162,8 +233,8 @@ TclOO_Class_CreateNs(
     if (oPtr->classPtr == NULL) {
 	Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
 
-	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
-		"\" is not a class", NULL);
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"object \"%s\" is not a class", TclGetString(cmdnameObj)));
 	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 	return TCL_ERROR;
     }
@@ -180,14 +251,16 @@ TclOO_Class_CreateNs(
     objName = Tcl_GetStringFromObj(
 	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
     if (len == 0) {
-	Tcl_AppendResult(interp, "object name must not be empty", NULL);
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"object name must not be empty", -1));
 	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
 	return TCL_ERROR;
     }
     nsName = Tcl_GetStringFromObj(
 	    objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
     if (len == 0) {
-	Tcl_AppendResult(interp, "namespace name must not be empty", NULL);
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"namespace name must not be empty", -1));
 	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
 	return TCL_ERROR;
     }
@@ -231,8 +304,8 @@ TclOO_Class_New(
     if (oPtr->classPtr == NULL) {
 	Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
 
-	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
-		"\" is not a class", NULL);
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"object \"%s\" is not a class", TclGetString(cmdnameObj)));
 	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 	return TCL_ERROR;
     }
@@ -434,6 +507,7 @@ TclOO_Object_Unknown(
     Object *oPtr = contextPtr->oPtr;
     const char **methodNames;
     int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+    Tcl_Obj *errorMsg;
 
     /*
      * If no method name, generate an error asking for a method name. (Only by
@@ -459,31 +533,34 @@ TclOO_Object_Unknown(
 
     if (numMethodNames == 0) {
 	Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
+	const char *piece;
 
-	Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL);
 	if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
-	    Tcl_AppendResult(interp, "\" has no visible methods", NULL);
+	    piece = "visible methods";
 	} else {
-	    Tcl_AppendResult(interp, "\" has no methods", NULL);
+	    piece = "methods";
 	}
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"object \"%s\" has no %s", TclGetString(tmpBuf), piece));
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
 		TclGetString(objv[skip]), NULL);
 	return TCL_ERROR;
     }
 
-    Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]),
-	    "\": must be ", NULL);
+    errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
+	    TclGetString(objv[skip]));
     for (i=0 ; i<numMethodNames-1 ; i++) {
 	if (i) {
-	    Tcl_AppendResult(interp, ", ", NULL);
+	    Tcl_AppendToObj(errorMsg, ", ", -1);
 	}
-	Tcl_AppendResult(interp, methodNames[i], NULL);
+	Tcl_AppendToObj(errorMsg, methodNames[i], -1);
     }
     if (i) {
-	Tcl_AppendResult(interp, " or ", NULL);
+	Tcl_AppendToObj(errorMsg, " or ", -1);
     }
-    Tcl_AppendResult(interp, methodNames[i], NULL);
+    Tcl_AppendToObj(errorMsg, methodNames[i], -1);
     ckfree(methodNames);
+    Tcl_SetObjResult(interp, errorMsg);
     Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
 	    TclGetString(objv[skip]), NULL);
     return TCL_ERROR;
@@ -539,8 +616,9 @@ TclOO_Object_LinkVar(
 	 */
 
 	if (strstr(varName, "::") != NULL) {
-	    Tcl_AppendResult(interp, "variable name \"", varName,
-		    "\" illegal: must not contain namespace separator", NULL);
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "variable name \"%s\" illegal: must not contain namespace"
+		    " separator", varName));
 	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
 	    return TCL_ERROR;
 	}
@@ -714,8 +792,9 @@ TclOONextObjCmd(
      */
 
     if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
-	Tcl_AppendResult(interp, TclGetString(objv[0]),
-		" may only be called from inside a method", NULL);
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"%s may only be called from inside a method",
+		TclGetString(objv[0])));
 	Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
 	return TCL_ERROR;
     }
@@ -752,8 +831,9 @@ TclOONextToObjCmd(
      */
 
     if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
-	Tcl_AppendResult(interp, TclGetString(objv[0]),
-		" may only be called from inside a method", NULL);
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"%s may only be called from inside a method",
+		TclGetString(objv[0])));
 	Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
 	return TCL_ERROR;
     }
@@ -773,8 +853,9 @@ TclOONextToObjCmd(
     }
     classPtr = ((Object *)object)->classPtr;
     if (classPtr == NULL) {
-	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
-		"\" is not a class", NULL);
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"\"%s\" is not a class", TclGetString(objv[1])));
+	Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
 	return TCL_ERROR;
     }
 
@@ -811,14 +892,15 @@ TclOONextToObjCmd(
 	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
 
 	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
-	    Tcl_AppendResult(interp, "method implementation by \"",
-		    TclGetString(objv[1]), "\" not reachable from here",
-		    NULL);
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "method implementation by \"%s\" not reachable from here",
+		    TclGetString(objv[1])));
 	    return TCL_ERROR;
 	}
     }
-    Tcl_AppendResult(interp, "method has no non-filter implementation by \"",
-	    TclGetString(objv[1]), "\"", NULL);
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "method has no non-filter implementation by \"%s\"",
+	    TclGetString(objv[1])));
     return TCL_ERROR;
 }
 
@@ -878,8 +960,9 @@ TclOOSelfObjCmd(
      */
 
     if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
-	Tcl_AppendResult(interp, TclGetString(objv[0]),
-		" may only be called from inside a method", NULL);
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"%s may only be called from inside a method",
+		TclGetString(objv[0])));
 	Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
 	return TCL_ERROR;
     }
@@ -913,7 +996,8 @@ TclOOSelfObjCmd(
 	Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
 
 	if (clsPtr == NULL) {
-	    Tcl_AppendResult(interp, "method not defined by a class", NULL);
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "method not defined by a class", -1));
 	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
 	    return TCL_ERROR;
 	}
@@ -933,7 +1017,8 @@ TclOOSelfObjCmd(
 	return TCL_OK;
     case SELF_FILTER:
 	if (!CurrentlyInvoked(contextPtr).isFilter) {
-	    Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "not inside a filtering context", -1));
 	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
 	    return TCL_ERROR;
 	} else {
@@ -958,7 +1043,8 @@ TclOOSelfObjCmd(
     case SELF_CALLER:
 	if ((framePtr->callerVarPtr == NULL) ||
 		!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
-	    Tcl_AppendResult(interp, "caller is not an object", NULL);
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "caller is not an object", -1));
 	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
 	    return TCL_ERROR;
 	} else {
@@ -975,7 +1061,8 @@ TclOOSelfObjCmd(
 		 * This should be unreachable code.
 		 */
 
-		Tcl_AppendResult(interp, "method without declarer!", NULL);
+		Tcl_SetObjResult(interp, Tcl_NewStringObj(
+			"method without declarer!", -1));
 		return TCL_ERROR;
 	    }
 
@@ -1006,7 +1093,8 @@ TclOOSelfObjCmd(
 		 * This should be unreachable code.
 		 */
 
-		Tcl_AppendResult(interp, "method without declarer!", NULL);
+		Tcl_SetObjResult(interp, Tcl_NewStringObj(
+			"method without declarer!", -1));
 		return TCL_ERROR;
 	    }
 
@@ -1023,7 +1111,8 @@ TclOOSelfObjCmd(
 	return TCL_OK;
     case SELF_TARGET:
 	if (!CurrentlyInvoked(contextPtr).isFilter) {
-	    Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "not inside a filtering context", -1));
 	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
 	    return TCL_ERROR;
 	} else {
@@ -1049,7 +1138,8 @@ TclOOSelfObjCmd(
 		 * This should be unreachable code.
 		 */
 
-		Tcl_AppendResult(interp, "method without declarer!", NULL);
+		Tcl_SetObjResult(interp, Tcl_NewStringObj(
+			"method without declarer!", -1));
 		return TCL_ERROR;
 	    }
 	    result[0] = TclOOObjectName(interp, declarerPtr);
@@ -1120,7 +1210,7 @@ TclOOCopyObjectCmd(
 		Tcl_DStringAppend(&buffer,
 			iPtr->varFramePtr->nsPtr->fullName, -1);
 	    }
-	    Tcl_DStringAppend(&buffer, "::", 2);
+	    TclDStringAppendLiteral(&buffer, "::");
 	    Tcl_DStringAppend(&buffer, name, -1);
 	    name = Tcl_DStringValue(&buffer);
 	}
@@ -1141,74 +1231,6 @@ TclOOCopyObjectCmd(
 }
 
 /*
- * ----------------------------------------------------------------------
- *
- * TclOOUpcatchCmd --
- *
- *	Implementation of the [oo::UpCatch] command, which is a combination of
- *	[uplevel 1] and [catch] that makes it easier to write transparent
- *	error handling in scripts.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOOUpcatchCmd(
-    ClientData ignored,
-    Tcl_Interp *interp,
-    int objc,
-    Tcl_Obj *const objv[])
-{
-    return Tcl_NRCallObjProc(interp, TclOONRUpcatch, NULL, objc, objv);
-}
-
-static int
-UpcatchCallback(
-    ClientData data[],
-    Tcl_Interp *interp,
-    int result)
-{
-    Interp *iPtr = (Interp *) interp;
-    CallFrame *savedFramePtr = data[0];
-    Tcl_Obj *resultObj[2];
-    int rewind = iPtr->execEnvPtr->rewind;
-
-    iPtr->varFramePtr = savedFramePtr;
-    if (rewind || Tcl_LimitExceeded(interp)) {
-	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
-		"\n    (\"UpCatch\" body line %d)", Tcl_GetErrorLine(interp)));
-	return TCL_ERROR;
-    }
-    resultObj[0] = Tcl_GetObjResult(interp);
-    resultObj[1] = Tcl_GetReturnOptions(interp, result);
-    Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj));
-    return TCL_OK;
-}
-
-int
-TclOONRUpcatch(
-    ClientData ignored,
-    Tcl_Interp *interp,
-    int objc,
-    Tcl_Obj *const objv[])
-{
-    Interp *iPtr = (Interp *) interp;
-    CallFrame *savedFramePtr = iPtr->varFramePtr;
-
-    if (objc != 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "script");
-	return TCL_ERROR;
-    }
-    if (iPtr->varFramePtr->callerVarPtr != NULL) {
-	iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
-    }
-
-    Tcl_NRAddCallback(interp, UpcatchCallback, savedFramePtr, NULL,NULL,NULL);
-    return TclNREvalObjEx(interp, objv[1], TCL_EVAL_NOERR,
-	    iPtr->cmdFramePtr, 1);
-}
-
-/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4