merged tcl 8.1 branch back into the main trunk

1 files changed, 1025 insertions, 0 deletions

diff --git a/generic/tclResult.c b/generic/tclResult.c
new file mode 100644
index 0000000..002437d
--- /dev/null
+++ b/generic/tclResult.c
@@ -0,0 +1,1025 @@
+/* 
+ * tclResult.c --
+ *
+ *	This file contains code to manage the interpreter result.
+ *
+ * Copyright (c) 1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclResult.c,v 1.2 1999/04/16 00:46:53 stanton Exp $
+ */
+
+#include "tclInt.h"
+
+/*
+ * Function prototypes for local procedures in this file:
+ */
+
+static void             ResetObjResult _ANSI_ARGS_((Interp *iPtr));
+static void		SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
+			    int newSpace));
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SaveResult --
+ *
+ *      Takes a snapshot of the current result state of the interpreter.
+ *      The snapshot can be restored at any point by
+ *      Tcl_RestoreResult. Note that this routine does not 
+ *	preserve the errorCode, errorInfo, or flags fields so it
+ *	should not be used if an error is in progress.
+ *
+ *      Once a snapshot is saved, it must be restored by calling
+ *      Tcl_RestoreResult, or discarded by calling
+ *      Tcl_DiscardResult.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Resets the interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SaveResult(interp, statePtr)
+    Tcl_Interp *interp;		/* Interpreter to save. */
+    Tcl_SavedResult *statePtr;	/* Pointer to state structure. */
+{
+    Interp *iPtr = (Interp *) interp;
+
+    /*
+     * Move the result object into the save state.  Note that we don't need
+     * to change its refcount because we're moving it, not adding a new
+     * reference.  Put an empty object into the interpreter.
+     */
+
+    statePtr->objResultPtr = iPtr->objResultPtr;
+    iPtr->objResultPtr = Tcl_NewObj(); 
+    Tcl_IncrRefCount(iPtr->objResultPtr); 
+
+    /*
+     * Save the string result. 
+     */
+
+    statePtr->freeProc = iPtr->freeProc;
+    if (iPtr->result == iPtr->resultSpace) {
+	/*
+	 * Copy the static string data out of the interp buffer.
+	 */
+
+	statePtr->result = statePtr->resultSpace;
+	strcpy(statePtr->result, iPtr->result);
+	statePtr->appendResult = NULL;
+    } else if (iPtr->result == iPtr->appendResult) {
+	/*
+	 * Move the append buffer out of the interp.
+	 */
+
+	statePtr->appendResult = iPtr->appendResult;
+	statePtr->appendAvl = iPtr->appendAvl;
+	statePtr->appendUsed = iPtr->appendUsed;
+	statePtr->result = statePtr->appendResult;
+	iPtr->appendResult = NULL;
+	iPtr->appendAvl = 0;
+	iPtr->appendUsed = 0;
+    } else {
+	/*
+	 * Move the dynamic or static string out of the interpreter.
+	 */
+
+	statePtr->result = iPtr->result;
+	statePtr->appendResult = NULL;
+    }
+
+    iPtr->result = iPtr->resultSpace;
+    iPtr->resultSpace[0] = 0;
+    iPtr->freeProc = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RestoreResult --
+ *
+ *      Restores the state of the interpreter to a snapshot taken
+ *      by Tcl_SaveResult.  After this call, the token for
+ *      the interpreter state is no longer valid.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      Restores the interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_RestoreResult(interp, statePtr)
+    Tcl_Interp* interp;		/* Interpreter being restored. */
+    Tcl_SavedResult *statePtr;	/* State returned by Tcl_SaveResult. */
+{
+    Interp *iPtr = (Interp *) interp;
+
+    Tcl_ResetResult(interp);
+
+    /*
+     * Restore the string result.
+     */
+
+    iPtr->freeProc = statePtr->freeProc;
+    if (statePtr->result == statePtr->resultSpace) {
+	/*
+	 * Copy the static string data into the interp buffer.
+	 */
+
+	iPtr->result = iPtr->resultSpace;
+	strcpy(iPtr->result, statePtr->result);
+    } else if (statePtr->result == statePtr->appendResult) {
+	/*
+	 * Move the append buffer back into the interp.
+	 */
+
+	if (iPtr->appendResult != NULL) {
+	    ckfree((char *)iPtr->appendResult);
+	}
+
+	iPtr->appendResult = statePtr->appendResult;
+	iPtr->appendAvl = statePtr->appendAvl;
+	iPtr->appendUsed = statePtr->appendUsed;
+	iPtr->result = iPtr->appendResult;
+    } else {
+	/*
+	 * Move the dynamic or static string back into the interpreter.
+	 */
+
+	iPtr->result = statePtr->result;
+    }
+
+    /*
+     * Restore the object result.
+     */
+
+    Tcl_DecrRefCount(iPtr->objResultPtr);
+    iPtr->objResultPtr = statePtr->objResultPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DiscardResult --
+ *
+ *      Frees the memory associated with an interpreter snapshot
+ *      taken by Tcl_SaveResult.  If the snapshot is not
+ *      restored, this procedure must be called to discard it,
+ *      or the memory will be lost.
+ *
+ * Results:
+ *      None.
+ *
+ * Side effects:
+ *      None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DiscardResult(statePtr)
+    Tcl_SavedResult *statePtr;	/* State returned by Tcl_SaveResult. */
+{
+    TclDecrRefCount(statePtr->objResultPtr);
+
+    if (statePtr->result == statePtr->appendResult) {
+	ckfree(statePtr->appendResult);
+    } else if (statePtr->freeProc) {
+	if ((statePtr->freeProc == TCL_DYNAMIC)
+	        || (statePtr->freeProc == (Tcl_FreeProc *) free)) {
+	    ckfree(statePtr->result);
+	} else {
+	    (*statePtr->freeProc)(statePtr->result);
+	}
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetResult --
+ *
+ *	Arrange for "string" to be the Tcl return value.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	interp->result is left pointing either to "string" (if "copy" is 0)
+ *	or to a copy of string. Also, the object result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetResult(interp, string, freeProc)
+    Tcl_Interp *interp;		/* Interpreter with which to associate the
+				 * return value. */
+    register char *string;	/* Value to be returned.  If NULL, the
+				 * result is set to an empty string. */
+    Tcl_FreeProc *freeProc;	/* Gives information about the string:
+				 * TCL_STATIC, TCL_VOLATILE, or the address
+				 * of a Tcl_FreeProc such as free. */
+{
+    Interp *iPtr = (Interp *) interp;
+    int length;
+    register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
+    char *oldResult = iPtr->result;
+
+    if (string == NULL) {
+	iPtr->resultSpace[0] = 0;
+	iPtr->result = iPtr->resultSpace;
+	iPtr->freeProc = 0;
+    } else if (freeProc == TCL_VOLATILE) {
+	length = strlen(string);
+	if (length > TCL_RESULT_SIZE) {
+	    iPtr->result = (char *) ckalloc((unsigned) length+1);
+	    iPtr->freeProc = TCL_DYNAMIC;
+	} else {
+	    iPtr->result = iPtr->resultSpace;
+	    iPtr->freeProc = 0;
+	}
+	strcpy(iPtr->result, string);
+    } else {
+	iPtr->result = string;
+	iPtr->freeProc = freeProc;
+    }
+
+    /*
+     * If the old result was dynamically-allocated, free it up.  Do it
+     * here, rather than at the beginning, in case the new result value
+     * was part of the old result value.
+     */
+
+    if (oldFreeProc != 0) {
+	if ((oldFreeProc == TCL_DYNAMIC)
+		|| (oldFreeProc == (Tcl_FreeProc *) free)) {
+	    ckfree(oldResult);
+	} else {
+	    (*oldFreeProc)(oldResult);
+	}
+    }
+
+    /*
+     * Reset the object result since we just set the string result.
+     */
+
+    ResetObjResult(iPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetStringResult --
+ *
+ *	Returns an interpreter's result value as a string.
+ *
+ * Results:
+ *	The interpreter's result as a string.
+ *
+ * Side effects:
+ *	If the string result is empty, the object result is moved to the
+ *	string result, then the object result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_GetStringResult(interp)
+     register Tcl_Interp *interp; /* Interpreter whose result to return. */
+{
+    /*
+     * If the string result is empty, move the object result to the
+     * string result, then reset the object result.
+     */
+    
+    if (*(interp->result) == 0) {
+	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
+	        TCL_VOLATILE);
+    }
+    return interp->result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetObjResult --
+ *
+ *	Arrange for objPtr to be an interpreter's result value.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	interp->objResultPtr is left pointing to the object referenced
+ *	by objPtr. The object's reference count is incremented since
+ *	there is now a new reference to it. The reference count for any
+ *	old objResultPtr value is decremented. Also, the string result
+ *	is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetObjResult(interp, objPtr)
+    Tcl_Interp *interp;		/* Interpreter with which to associate the
+				 * return object value. */
+    register Tcl_Obj *objPtr;	/* Tcl object to be returned. If NULL, the
+				 * obj result is made an empty string
+				 * object. */
+{
+    register Interp *iPtr = (Interp *) interp;
+    register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
+
+    iPtr->objResultPtr = objPtr;
+    Tcl_IncrRefCount(objPtr);	/* since interp result is a reference */
+
+    /*
+     * We wait until the end to release the old object result, in case
+     * we are setting the result to itself.
+     */
+    
+    TclDecrRefCount(oldObjResult);
+
+    /*
+     * Reset the string result since we just set the result object.
+     */
+
+    if (iPtr->freeProc != NULL) {
+	if ((iPtr->freeProc == TCL_DYNAMIC)
+	        || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
+	    ckfree(iPtr->result);
+	} else {
+	    (*iPtr->freeProc)(iPtr->result);
+	}
+	iPtr->freeProc = 0;
+    }
+    iPtr->result = iPtr->resultSpace;
+    iPtr->resultSpace[0] = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetObjResult --
+ *
+ *	Returns an interpreter's result value as a Tcl object. The object's
+ *	reference count is not modified; the caller must do that if it
+ *	needs to hold on to a long-term reference to it.
+ *
+ * Results:
+ *	The interpreter's result as an object.
+ *
+ * Side effects:
+ *	If the interpreter has a non-empty string result, the result object
+ *	is either empty or stale because some procedure set interp->result
+ *	directly. If so, the string result is moved to the result object
+ *	then the string result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_GetObjResult(interp)
+    Tcl_Interp *interp;		/* Interpreter whose result to return. */
+{
+    register Interp *iPtr = (Interp *) interp;
+    Tcl_Obj *objResultPtr;
+    int length;
+
+    /*
+     * If the string result is non-empty, move the string result to the
+     * object result, then reset the string result.
+     */
+    
+    if (*(iPtr->result) != 0) {
+	ResetObjResult(iPtr);
+	
+	objResultPtr = iPtr->objResultPtr;
+	length = strlen(iPtr->result);
+	TclInitStringRep(objResultPtr, iPtr->result, length);
+	
+	if (iPtr->freeProc != NULL) {
+	    if ((iPtr->freeProc == TCL_DYNAMIC)
+	            || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
+		ckfree(iPtr->result);
+	    } else {
+		(*iPtr->freeProc)(iPtr->result);
+	    }
+	    iPtr->freeProc = 0;
+	}
+	iPtr->result = iPtr->resultSpace;
+	iPtr->resultSpace[0] = 0;
+    }
+    return iPtr->objResultPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppendResultVA --
+ *
+ *	Append a variable number of strings onto the interpreter's string
+ *	result.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The result of the interpreter given by the first argument is
+ *	extended by the strings in the va_list (up to a terminating NULL
+ *	argument).
+ *
+ *	If the string result is empty, the object result is moved to the
+ *	string result, then the object result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AppendResultVA (interp, argList)
+    Tcl_Interp *interp;		/* Interpreter with which to associate the
+				 * return value. */
+    va_list argList;		/* Variable argument list. */
+{
+    Interp *iPtr = (Interp *) interp;
+    va_list tmpArgList;
+    char *string;
+    int newSpace;
+
+    /*
+     * If the string result is empty, move the object result to the
+     * string result, then reset the object result.
+     */
+
+    if (*(iPtr->result) == 0) {
+	Tcl_SetResult((Tcl_Interp *) iPtr,
+	        TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)),
+	        TCL_VOLATILE);
+    }
+    
+    /*
+     * Scan through all the arguments to see how much space is needed.
+     */
+
+    tmpArgList = argList;
+    newSpace = 0;
+    while (1) {
+	string = va_arg(tmpArgList, char *);
+	if (string == NULL) {
+	    break;
+	}
+	newSpace += strlen(string);
+    }
+
+    /*
+     * If the append buffer isn't already setup and large enough to hold
+     * the new data, set it up.
+     */
+
+    if ((iPtr->result != iPtr->appendResult)
+	    || (iPtr->appendResult[iPtr->appendUsed] != 0)
+	    || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
+       SetupAppendBuffer(iPtr, newSpace);
+    }
+
+    /*
+     * Now go through all the argument strings again, copying them into the
+     * buffer.
+     */
+
+    while (1) {
+	string = va_arg(argList, char *);
+	if (string == NULL) {
+	    break;
+	}
+	strcpy(iPtr->appendResult + iPtr->appendUsed, string);
+	iPtr->appendUsed += strlen(string);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppendResult --
+ *
+ *	Append a variable number of strings onto the interpreter's string
+ *	result.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The result of the interpreter given by the first argument is
+ *	extended by the strings given by the second and following arguments
+ *	(up to a terminating NULL argument).
+ *
+ *	If the string result is empty, the object result is moved to the
+ *	string result, then the object result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
+{
+    Tcl_Interp *interp;
+    va_list argList;
+
+    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
+    Tcl_AppendResultVA(interp, argList);
+    va_end(argList);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppendElement --
+ *
+ *	Convert a string to a valid Tcl list element and append it to the
+ *	result (which is ostensibly a list).
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The result in the interpreter given by the first argument is
+ *	extended with a list element converted from string. A separator
+ *	space is added before the converted list element unless the current
+ *	result is empty, contains the single character "{", or ends in " {".
+ *
+ *	If the string result is empty, the object result is moved to the
+ *	string result, then the object result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AppendElement(interp, string)
+    Tcl_Interp *interp;		/* Interpreter whose result is to be
+				 * extended. */
+    CONST char *string;		/* String to convert to list element and
+				 * add to result. */
+{
+    Interp *iPtr = (Interp *) interp;
+    char *dst;
+    int size;
+    int flags;
+
+    /*
+     * If the string result is empty, move the object result to the
+     * string result, then reset the object result.
+     */
+
+    if (*(iPtr->result) == 0) {
+	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
+	        TCL_VOLATILE);
+    }
+
+    /*
+     * See how much space is needed, and grow the append buffer if
+     * needed to accommodate the list element.
+     */
+
+    size = Tcl_ScanElement(string, &flags) + 1;
+    if ((iPtr->result != iPtr->appendResult)
+	    || (iPtr->appendResult[iPtr->appendUsed] != 0)
+	    || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
+       SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
+    }
+
+    /*
+     * Convert the string into a list element and copy it to the
+     * buffer that's forming, with a space separator if needed.
+     */
+
+    dst = iPtr->appendResult + iPtr->appendUsed;
+    if (TclNeedSpace(iPtr->appendResult, dst)) {
+	iPtr->appendUsed++;
+	*dst = ' ';
+	dst++;
+    }
+    iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetupAppendBuffer --
+ *
+ *	This procedure makes sure that there is an append buffer properly
+ *	initialized, if necessary, from the interpreter's result, and
+ *	that it has at least enough room to accommodate newSpace new
+ *	bytes of information.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+SetupAppendBuffer(iPtr, newSpace)
+    Interp *iPtr;		/* Interpreter whose result is being set up. */
+    int newSpace;		/* Make sure that at least this many bytes
+				 * of new information may be added. */
+{
+    int totalSpace;
+
+    /*
+     * Make the append buffer larger, if that's necessary, then copy the
+     * result into the append buffer and make the append buffer the official
+     * Tcl result.
+     */
+
+    if (iPtr->result != iPtr->appendResult) {
+	/*
+	 * If an oversized buffer was used recently, then free it up
+	 * so we go back to a smaller buffer.  This avoids tying up
+	 * memory forever after a large operation.
+	 */
+
+	if (iPtr->appendAvl > 500) {
+	    ckfree(iPtr->appendResult);
+	    iPtr->appendResult = NULL;
+	    iPtr->appendAvl = 0;
+	}
+	iPtr->appendUsed = strlen(iPtr->result);
+    } else if (iPtr->result[iPtr->appendUsed] != 0) {
+	/*
+	 * Most likely someone has modified a result created by
+	 * Tcl_AppendResult et al. so that it has a different size.
+	 * Just recompute the size.
+	 */
+
+	iPtr->appendUsed = strlen(iPtr->result);
+    }
+    
+    totalSpace = newSpace + iPtr->appendUsed;
+    if (totalSpace >= iPtr->appendAvl) {
+	char *new;
+
+	if (totalSpace < 100) {
+	    totalSpace = 200;
+	} else {
+	    totalSpace *= 2;
+	}
+	new = (char *) ckalloc((unsigned) totalSpace);
+	strcpy(new, iPtr->result);
+	if (iPtr->appendResult != NULL) {
+	    ckfree(iPtr->appendResult);
+	}
+	iPtr->appendResult = new;
+	iPtr->appendAvl = totalSpace;
+    } else if (iPtr->result != iPtr->appendResult) {
+	strcpy(iPtr->appendResult, iPtr->result);
+    }
+    
+    Tcl_FreeResult((Tcl_Interp *) iPtr);
+    iPtr->result = iPtr->appendResult;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FreeResult --
+ *
+ *	This procedure frees up the memory associated with an interpreter's
+ *	string result. It also resets the interpreter's result object.
+ *	Tcl_FreeResult is most commonly used when a procedure is about to
+ *	replace one result value with another.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Frees the memory associated with interp's string result and sets
+ *	interp->freeProc to zero, but does not change interp->result or
+ *	clear error state. Resets interp's result object to an unshared
+ *	empty object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FreeResult(interp)
+    register Tcl_Interp *interp; /* Interpreter for which to free result. */
+{
+    register Interp *iPtr = (Interp *) interp;
+    
+    if (iPtr->freeProc != NULL) {
+	if ((iPtr->freeProc == TCL_DYNAMIC)
+	        || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
+	    ckfree(iPtr->result);
+	} else {
+	    (*iPtr->freeProc)(iPtr->result);
+	}
+	iPtr->freeProc = 0;
+    }
+    
+    ResetObjResult(iPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ResetResult --
+ *
+ *	This procedure resets both the interpreter's string and object
+ *	results.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	It resets the result object to an unshared empty object. It
+ *	then restores the interpreter's string result area to its default
+ *	initialized state, freeing up any memory that may have been
+ *	allocated. It also clears any error information for the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ResetResult(interp)
+    register Tcl_Interp *interp; /* Interpreter for which to clear result. */
+{
+    register Interp *iPtr = (Interp *) interp;
+
+    ResetObjResult(iPtr);
+    if (iPtr->freeProc != NULL) {
+	if ((iPtr->freeProc == TCL_DYNAMIC)
+	        || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
+	    ckfree(iPtr->result);
+	} else {
+	    (*iPtr->freeProc)(iPtr->result);
+	}
+	iPtr->freeProc = 0;
+    }
+    iPtr->result = iPtr->resultSpace;
+    iPtr->resultSpace[0] = 0;
+    iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ResetObjResult --
+ *
+ *	Procedure used to reset an interpreter's Tcl result object.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Resets the interpreter's result object to an unshared empty string
+ *	object with ref count one. It does not clear any error information
+ *	in the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ResetObjResult(iPtr)
+    register Interp *iPtr;	/* Points to the interpreter whose result
+				 * object should be reset. */
+{
+    register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
+
+    if (Tcl_IsShared(objResultPtr)) {
+	TclDecrRefCount(objResultPtr);
+	TclNewObj(objResultPtr);
+	Tcl_IncrRefCount(objResultPtr);
+	iPtr->objResultPtr = objResultPtr;
+    } else {
+	if ((objResultPtr->bytes != NULL)
+	        && (objResultPtr->bytes != tclEmptyStringRep)) {
+	    ckfree((char *) objResultPtr->bytes);
+	}
+	objResultPtr->bytes  = tclEmptyStringRep;
+	objResultPtr->length = 0;
+	if ((objResultPtr->typePtr != NULL)
+	        && (objResultPtr->typePtr->freeIntRepProc != NULL)) {
+	    objResultPtr->typePtr->freeIntRepProc(objResultPtr);
+	}
+	objResultPtr->typePtr = (Tcl_ObjType *) NULL;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetErrorCodeVA --
+ *
+ *	This procedure is called to record machine-readable information
+ *	about an error that is about to be returned.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The errorCode global variable is modified to hold all of the
+ *	arguments to this procedure, in a list form with each argument
+ *	becoming one element of the list.  A flag is set internally
+ *	to remember that errorCode has been set, so the variable doesn't
+ *	get set automatically when the error is returned.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetErrorCodeVA (interp, argList)
+    Tcl_Interp *interp;		/* Interpreter in which to access the errorCode
+				 * variable. */
+    va_list argList;		/* Variable argument list. */
+{
+    char *string;
+    int flags;
+    Interp *iPtr = (Interp *) interp;
+
+    /*
+     * Scan through the arguments one at a time, appending them to
+     * $errorCode as list elements.
+     */
+
+    flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
+    while (1) {
+	string = va_arg(argList, char *);
+	if (string == NULL) {
+	    break;
+	}
+	(void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
+		(char *) NULL, string, flags);
+	flags |= TCL_APPEND_VALUE;
+    }
+    iPtr->flags |= ERROR_CODE_SET;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetErrorCode --
+ *
+ *	This procedure is called to record machine-readable information
+ *	about an error that is about to be returned.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The errorCode global variable is modified to hold all of the
+ *	arguments to this procedure, in a list form with each argument
+ *	becoming one element of the list.  A flag is set internally
+ *	to remember that errorCode has been set, so the variable doesn't
+ *	get set automatically when the error is returned.
+ *
+ *----------------------------------------------------------------------
+ */
+	/* VARARGS2 */
+void
+Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
+{
+    Tcl_Interp *interp;
+    va_list argList;
+
+    /*
+     * Scan through the arguments one at a time, appending them to
+     * $errorCode as list elements.
+     */
+
+    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
+    Tcl_SetErrorCodeVA(interp, argList);
+    va_end(argList);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetObjErrorCode --
+ *
+ *	This procedure is called to record machine-readable information
+ *	about an error that is about to be returned. The caller should
+ *	build a list object up and pass it to this routine.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The errorCode global variable is modified to be the new value.
+ *	A flag is set internally to remember that errorCode has been
+ *	set, so the variable doesn't get set automatically when the
+ *	error is returned.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetObjErrorCode(interp, errorObjPtr)
+    Tcl_Interp *interp;
+    Tcl_Obj *errorObjPtr;
+{
+    Interp *iPtr;
+    
+    iPtr = (Interp *) interp;
+    Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY);
+    iPtr->flags |= ERROR_CODE_SET;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclTransferResult --
+ *
+ *	Copy the result (and error information) from one interp to 
+ *	another.  Used when one interp has caused another interp to 
+ *	evaluate a script and then wants to transfer the results back
+ *	to itself.
+ *
+ *	This routine copies the string reps of the result and error 
+ *	information.  It does not simply increment the refcounts of the
+ *	result and error information objects themselves.
+ *	It is not legal to exchange objects between interps, because an
+ *	object may be kept alive by one interp, but have an internal rep 
+ *	that is only valid while some other interp is alive.  
+ *
+ * Results:
+ *	The target interp's result is set to a copy of the source interp's
+ *	result.  The source's error information "$errorInfo" may be
+ *	appended to the target's error information and the source's error
+ *	code "$errorCode" may be stored in the target's error code.
+ *
+ * Side effects:
+ *	None.
+ *
+ *-------------------------------------------------------------------------
+ */
+	
+void
+TclTransferResult(sourceInterp, result, targetInterp)
+    Tcl_Interp *sourceInterp;	/* Interp whose result and error information
+				 * should be moved to the target interp.  
+				 * After moving result, this interp's result 
+				 * is reset. */
+    int result;			/* TCL_OK if just the result should be copied, 
+				 * TCL_ERROR if both the result and error 
+				 * information should be copied. */
+    Tcl_Interp *targetInterp;	/* Interp where result and error information 
+				 * should be stored.  If source and target
+				 * are the same, nothing is done. */
+{
+    Interp *iPtr;
+    Tcl_Obj *objPtr;
+
+    if (sourceInterp == targetInterp) {
+	return;
+    }
+
+    if (result == TCL_ERROR) {
+	/*
+	 * An error occurred, so transfer error information from the source
+	 * interpreter to the target interpreter.  Setting the flags tells
+	 * the target interp that it has inherited a partial traceback
+	 * chain, not just a simple error message.
+	 */
+
+	iPtr = (Interp *) sourceInterp;
+        if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) {
+            Tcl_AddErrorInfo(sourceInterp, "");
+        }
+        iPtr->flags &= ~(ERR_ALREADY_LOGGED);
+        
+        Tcl_ResetResult(targetInterp);
+        
+	objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
+		TCL_GLOBAL_ONLY);
+	Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
+		TCL_GLOBAL_ONLY);
+
+	objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
+		TCL_GLOBAL_ONLY);
+	Tcl_SetVar2Ex(targetInterp, "errorCode", NULL, objPtr,
+		TCL_GLOBAL_ONLY);
+
+	((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET);
+    }
+
+    ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
+    Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
+    Tcl_ResetResult(sourceInterp);
+}