1 files changed, 250 insertions, 125 deletions

diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index b26061e..0676618 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -4,12 +4,10 @@
  *	This file contains implementations of the "simple" commands and
  *	methods from the object-system core.
  *
- * Copyright (c) 2005-2008 by Donal K. Fellows
+ * Copyright (c) 2005-2012 by Donal K. Fellows
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclOOBasic.c,v 1.24 2010/02/05 13:41:33 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -21,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[],
@@ -72,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.
@@ -100,8 +168,9 @@ 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;
     }
 
@@ -117,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;
     }
@@ -163,8 +233,9 @@ 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,9 @@ 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;
     }
 
@@ -278,9 +352,9 @@ TclOO_Object_Destroy(
 	if (contextPtr != NULL) {
 	    contextPtr->callPtr->flags |= DESTRUCTOR;
 	    contextPtr->skip = 0;
-	    AddRef(oPtr);
-	    TclNRAddCallback(interp, AfterNRDestructor, oPtr, contextPtr,
-		    NULL, NULL);
+	    TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
+		    NULL, NULL, NULL);
+	    TclPushTailcallPoint(interp);
 	    return TclOOInvokeContext(contextPtr, interp, 0, NULL);
 	}
     }
@@ -296,14 +370,12 @@ AfterNRDestructor(
     Tcl_Interp *interp,
     int result)
 {
-    Object *oPtr = data[0];
-    CallContext *contextPtr = data[1];
+    CallContext *contextPtr = data[0];
 
-    TclOODeleteContext(contextPtr);
-    if (oPtr->command) {
-	Tcl_DeleteCommandFromToken(interp, oPtr->command);
+    if (contextPtr->oPtr->command) {
+	Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
     }
-    DelRef(oPtr);
+    TclOODeleteContext(contextPtr);
     return result;
 }
 
@@ -435,9 +507,16 @@ 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
+     * overriding *this* method can an object handle the absence of a method
+     * name without an error).
+     */
 
     if (objc < skip+1) {
-	Tcl_WrongNumArgs(interp, skip, objv, "methodName ?arg ...?");
+	Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
 	return TCL_ERROR;
     }
 
@@ -454,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);
-    ckfree((char *) methodNames);
+    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;
@@ -534,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;
 	}
@@ -682,10 +765,11 @@ TclOO_Object_VarName(
 /*
  * ----------------------------------------------------------------------
  *
- * TclOONextObjCmd --
+ * TclOONextObjCmd, TclOONextToObjCmd --
  *
- *	Implementation of the [next] command. Note that this command is only
- *	ever to be used inside the body of a procedure-like method.
+ *	Implementation of the [next] and [nextto] commands. Note that these
+ *	commands are only ever to be used inside the body of a procedure-like
+ *	method.
  *
  * ----------------------------------------------------------------------
  */
@@ -708,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;
     }
@@ -725,6 +810,100 @@ TclOONextObjCmd(
     return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
 }
 
+int
+TclOONextToObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *framePtr = iPtr->varFramePtr;
+    Class *classPtr;
+    CallContext *contextPtr;
+    int i;
+    Tcl_Object object;
+
+    /*
+     * Start with sanity checks on the calling context to make sure that we
+     * are invoked from a suitable method context. If so, we can safely
+     * retrieve the handle to the object call context.
+     */
+
+    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	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;
+    }
+    contextPtr = framePtr->clientData;
+
+    /*
+     * Sanity check the arguments; we need the first one to refer to a class.
+     */
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?");
+	return TCL_ERROR;
+    }
+    object = Tcl_GetObjectFromObj(interp, objv[1]);
+    if (object == NULL) {
+	return TCL_ERROR;
+    }
+    classPtr = ((Object *)object)->classPtr;
+    if (classPtr == 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;
+    }
+
+    /*
+     * Search for an implementation of a method associated with the current
+     * call on the call chain past the point where we currently are. Do not
+     * allow jumping backwards!
+     */
+
+    for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
+	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+
+	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
+	    /*
+	     * Invoke the (advanced) method call context in the caller
+	     * context. Note that this is like [uplevel 1] and not [eval].
+	     */
+
+	    TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr,
+		    INT2PTR(contextPtr->index), NULL);
+	    contextPtr->index = i-1;
+	    iPtr->varFramePtr = framePtr->callerVarPtr;
+	    return TclNRObjectContextInvokeNext(interp,
+		    (Tcl_ObjectContext) contextPtr, objc, objv, 2);
+	}
+    }
+
+    /*
+     * Generate an appropriate error message, depending on whether the value
+     * is on the chain but unreachable, or not on the chain at all.
+     */
+
+    for (i=contextPtr->index ; i>=0 ; i--) {
+	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+
+	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "method implementation by \"%s\" not reachable from here",
+		    TclGetString(objv[1])));
+	    return TCL_ERROR;
+	}
+    }
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "method has no non-filter implementation by \"%s\"",
+	    TclGetString(objv[1])));
+    return TCL_ERROR;
+}
+
 static int
 RestoreFrame(
     ClientData data[],
@@ -732,8 +911,12 @@ RestoreFrame(
     int result)
 {
     Interp *iPtr = (Interp *) interp;
+    CallContext *contextPtr = data[1];
 
     iPtr->varFramePtr = data[0];
+    if (contextPtr != NULL) {
+	contextPtr->index = PTR2INT(data[2]);
+    }
     return result;
 }
 
@@ -756,16 +939,17 @@ TclOOSelfObjCmd(
     Tcl_Obj *const *objv)
 {
     static const char *const subcmds[] = {
-	"caller", "class", "filter", "method", "namespace", "next", "object",
-	"target", NULL
+	"call", "caller", "class", "filter", "method", "namespace", "next",
+	"object", "target", NULL
     };
     enum SelfCmds {
-	SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT,
-	SELF_OBJECT, SELF_TARGET
+	SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS,
+	SELF_NEXT, SELF_OBJECT, SELF_TARGET
     };
     Interp *iPtr = (Interp *) interp;
     CallFrame *framePtr = iPtr->varFramePtr;
     CallContext *contextPtr;
+    Tcl_Obj *result[3];
     int index;
 
 #define CurrentlyInvoked(contextPtr) \
@@ -776,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;
     }
@@ -811,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;
 	}
@@ -831,12 +1017,12 @@ 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 {
 	    register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
-	    Tcl_Obj *result[3];
 	    Object *oPtr;
 	    const char *type;
 
@@ -857,14 +1043,14 @@ 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 {
 	    CallContext *callerPtr = framePtr->callerVarPtr->clientData;
 	    Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
 	    Object *declarerPtr;
-	    Tcl_Obj *result[3];
 
 	    if (mPtr->declaringClassPtr != NULL) {
 		declarerPtr = mPtr->declaringClassPtr->thisPtr;
@@ -875,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;
 	    }
 
@@ -896,7 +1083,6 @@ TclOOSelfObjCmd(
 	    Method *mPtr =
 		    contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
 	    Object *declarerPtr;
-	    Tcl_Obj *result[2];
 
 	    if (mPtr->declaringClassPtr != NULL) {
 		declarerPtr = mPtr->declaringClassPtr->thisPtr;
@@ -907,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;
 	    }
 
@@ -924,13 +1111,13 @@ 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 {
 	    Method *mPtr;
 	    Object *declarerPtr;
-	    Tcl_Obj *result[2];
 	    int i;
 
 	    for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
@@ -951,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);
@@ -959,6 +1147,11 @@ TclOOSelfObjCmd(
 	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
 	    return TCL_OK;
 	}
+    case SELF_CALL:
+	result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
+	result[1] = Tcl_NewIntObj(contextPtr->index);
+	Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
+	return TCL_OK;
     }
     return TCL_ERROR;
 }
@@ -1017,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);
 	}
@@ -1038,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