path: root/generic/tclResult.c

/* 
 * 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.18 2004/10/21 15:19:47 dgp 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));

/*
 *  This structure is used to take a snapshot of the interpreter
 *  state in TclSaveInterpState.  You can snapshot the state,
 *  execute a command, and then back up to the result or the
 *  error that was previously in progress.
 */
typedef struct InterpState {
    int status;			/* return code status */
    int flags;			/* Each remaining field saves */
    int returnLevel;		/* the corresponding field of */
    int returnCode;		/* the Interp struct.  These */
    Tcl_Obj *errorInfo;		/* fields take together are the */
    Tcl_Obj *errorCode;		/* "state" of the interp. */
    Tcl_Obj *returnOpts;
    Tcl_Obj *objResult;
} InterpState;


/*
 *----------------------------------------------------------------------
 *
 * TclSaveInterpState --
 *
 *      Fills a token with a snapshot of the current state of the
 *      interpreter.  The snapshot can be restored at any point by
 *      TclRestoreInterpState. 
 *
 *      The token returned must be eventally passed to one of the
 *      routines TclRestoreInterpState or TclDiscardInterpState,
 *      or there will be a memory leak.
 *
 * Results:
 *	Returns a token representing the interp state.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

TclInterpState
TclSaveInterpState(interp, status)
    Tcl_Interp* interp;     /* Interpreter's state to be saved */
    int status;             /* status code for current operation */
{
    Interp *iPtr = (Interp *)interp;
    InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));

    statePtr->status = status;
    statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
    statePtr->returnLevel = iPtr->returnLevel;
    statePtr->returnCode = iPtr->returnCode;
    statePtr->errorInfo = iPtr->errorInfo;
    if (statePtr->errorInfo) {
	Tcl_IncrRefCount(statePtr->errorInfo);
    }
    statePtr->errorCode = iPtr->errorCode;
    if (statePtr->errorCode) {
	Tcl_IncrRefCount(statePtr->errorCode);
    }
    statePtr->returnOpts = iPtr->returnOpts;
    if (statePtr->returnOpts) {
	Tcl_IncrRefCount(statePtr->returnOpts);
    }
    statePtr->objResult = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(statePtr->objResult);
    return (TclInterpState) statePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclRestoreInterpState --
 *
 *      Accepts an interp and a token previously returned by
 *      TclSaveInterpState.  Restore the state of the interp
 *      to what it was at the time of the TclSaveInterpState call.
 *
 * Results:
 *	Returns the status value originally passed in to TclSaveInterpState.
 *
 * Side effects:
 *	Restores the interp state and frees memory held by token.
 *
 *----------------------------------------------------------------------
 */

int
TclRestoreInterpState(interp, state)
    Tcl_Interp* interp;		/* Interpreter's state to be restored*/
    TclInterpState state;	/* saved interpreter state */
{
    Interp *iPtr = (Interp *)interp;
    InterpState *statePtr = (InterpState *)state;
    int status = statePtr->status;

    iPtr->flags &= ~ERR_ALREADY_LOGGED;
    iPtr->flags |= (statePtr->flags & ERR_ALREADY_LOGGED);

    iPtr->returnLevel = statePtr->returnLevel;
    iPtr->returnCode = statePtr->returnCode;
    if (iPtr->errorInfo) {
	Tcl_DecrRefCount(iPtr->errorInfo);
    }
    iPtr->errorInfo = statePtr->errorInfo;
    if (iPtr->errorInfo) {
	Tcl_IncrRefCount(iPtr->errorInfo);
    }
    if (iPtr->errorCode) {
	Tcl_DecrRefCount(iPtr->errorCode);
    }
    iPtr->errorCode = statePtr->errorCode;
    if (iPtr->errorCode) {
	Tcl_IncrRefCount(iPtr->errorCode);
    }
    if (iPtr->returnOpts) {
	Tcl_DecrRefCount(iPtr->returnOpts);
    }
    iPtr->returnOpts = statePtr->returnOpts;
    if (iPtr->returnOpts) {
	Tcl_IncrRefCount(iPtr->returnOpts);
    }
    Tcl_SetObjResult(interp, statePtr->objResult);
    TclDiscardInterpState(state);
    return status;
}

/*
 *----------------------------------------------------------------------
 *
 * TclDiscardInterpState --
 *
 *      Accepts a token previously returned by TclSaveInterpState.
 *      Frees the memory it uses.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees memory.
 *
 *----------------------------------------------------------------------
 */

void
TclDiscardInterpState(state)
    TclInterpState state;	/* saved interpreter state */
{
    InterpState *statePtr = (InterpState *)state;

    if (statePtr->errorInfo) {
        Tcl_DecrRefCount(statePtr->errorInfo);
    }
    if (statePtr->errorCode) {
        Tcl_DecrRefCount(statePtr->errorCode);
    }
    if (statePtr->returnOpts) {
        Tcl_DecrRefCount(statePtr->returnOpts);
    }
    Tcl_DecrRefCount(statePtr->objResult);
    ckfree((char*) statePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * 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) {
	    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, stringPtr, freeProc)
    Tcl_Interp *interp;		/* Interpreter with which to associate the
				 * return value. */
    register char *stringPtr;	/* 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 (stringPtr == NULL) {
	iPtr->resultSpace[0] = 0;
	iPtr->result = iPtr->resultSpace;
	iPtr->freeProc = 0;
    } else if (freeProc == TCL_VOLATILE) {
	length = strlen(stringPtr);
	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, stringPtr);
    } else {
	iPtr->result = stringPtr;
	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) {
	    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.
 *
 *----------------------------------------------------------------------
 */

CONST 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) {
	    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) {
		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
 *	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 non-empty, the object result forced to
 *	be a duplicate of it first. There will be a string result
 *	afterwards.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendResultVA(interp, argList)
    Tcl_Interp *interp;		/* Interpreter with which to associate the
				 * return value. */
    va_list argList;		/* Variable argument list. */
{
    Tcl_Obj *objPtr = Tcl_GetObjResult(interp);

    if (Tcl_IsShared(objPtr)) {
	objPtr = Tcl_DuplicateObj(objPtr);
    }
    Tcl_AppendStringsToObjVA(objPtr, argList);
    Tcl_SetObjResult(interp, objPtr);
    /*
     * Ensure that the interp->result is legal so old Tcl 7.* code
     * still works. There's still embarrasingly much of it about...
     */
    (void) Tcl_GetStringResult(interp);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendResult --
 *
 *	Append a variable number of strings onto the interpreter's
 *	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 non-empty, the object result forced to
 *	be a duplicate of it first. There will be a string result
 *	afterwards.
 *
 *----------------------------------------------------------------------
 */

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, stringPtr)
    Tcl_Interp *interp;		/* Interpreter whose result is to be
				 * extended. */
    CONST char *stringPtr;	/* 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.
     */

    (void) Tcl_GetStringResult(interp);

    /*
     * See how much space is needed, and grow the append buffer if
     * needed to accommodate the list element.
     */

    size = Tcl_ScanElement(stringPtr, &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++;
	/*
	 * If we need a space to separate this element from preceding
	 * stuff, then this element will not lead a list, and need not
	 * have it's leading '#' quoted.
	 */
	flags |= TCL_DONT_QUOTE_HASH;
    }
    iPtr->appendUsed += Tcl_ConvertElement(stringPtr, 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) {
	    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) {
	    ckfree(iPtr->result);
	} else {
	    (*iPtr->freeProc)(iPtr->result);
	}
	iPtr->freeProc = 0;
    }
    iPtr->result = iPtr->resultSpace;
    iPtr->resultSpace[0] = 0;
    if (iPtr->errorCode) {
	/* Legacy support */
	Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
		iPtr->errorCode, TCL_GLOBAL_ONLY);
	Tcl_DecrRefCount(iPtr->errorCode);
	iPtr->errorCode = NULL;
    }
    if (iPtr->errorInfo) {
	/* Legacy support */
	Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
		iPtr->errorInfo, TCL_GLOBAL_ONLY);
	Tcl_DecrRefCount(iPtr->errorInfo);
	iPtr->errorInfo = NULL;
    }
    iPtr->flags &= ~ERR_ALREADY_LOGGED;
}

/*
 *----------------------------------------------------------------------
 *
 * 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;
	TclFreeIntRep(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 field of the interp is modified to hold all of the
 *	arguments to this procedure, in a list form with each argument
 *	becoming one element of the list.  
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetErrorCodeVA (interp, argList)
    Tcl_Interp *interp;		/* Interpreter in which to set errorCode */
    va_list argList;		/* Variable argument list. */
{
    Tcl_Obj *errorObj = Tcl_NewObj();

    /*
     * Scan through the arguments one at a time, appending them to
     * the errorCode field as list elements.
     */

    while (1) {
	char *elem = va_arg(argList, char *);
	if (elem == NULL) {
	    break;
	}
	Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1));
    }
    Tcl_SetObjErrorCode(interp, errorObj);
}

/*
 *----------------------------------------------------------------------
 *
 * 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 field of the interp is modified to hold all of the
 *	arguments to this procedure, in a list form with each argument
 *	becoming one element of the list.  
 *
 *----------------------------------------------------------------------
 */
	/* 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
     * the errorCode field 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 field of the interp is set to the new value.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetObjErrorCode(interp, errorObjPtr)
    Tcl_Interp *interp;
    Tcl_Obj *errorObjPtr;
{
    Interp *iPtr = (Interp *) interp;
    
    if (iPtr->errorCode) {
	Tcl_DecrRefCount(iPtr->errorCode);
    }
    iPtr->errorCode = errorObjPtr;
    Tcl_IncrRefCount(iPtr->errorCode);
}

/*
 *----------------------------------------------------------------------
 *
 * TclProcessReturn --
 *
 *	Does the work of the [return] command based on the code,
 *	level, and returnOpts arguments.  Note that the code argument
 *	must agree with the -code entry in returnOpts and the level
 *	argument must agree with the -level entry in returnOpts, as
 *	is the case for values returned from TclMergeReturnOptions.
 *
 * Results:
 *	Returns the return code the [return] command should return.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */
int
TclProcessReturn(interp, code, level, returnOpts)
    Tcl_Interp *interp;
    int code;
    int level;
    Tcl_Obj *returnOpts;
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *valuePtr;

    /* Store the merged return options */
    if (iPtr->returnOpts != returnOpts) {
	if (iPtr->returnOpts) {
	    Tcl_DecrRefCount(iPtr->returnOpts);
	}
	iPtr->returnOpts = returnOpts;
	Tcl_IncrRefCount(iPtr->returnOpts);
    }

    if (code == TCL_ERROR) {
	Tcl_DictObjGet(NULL, iPtr->returnOpts,
		iPtr->returnErrorinfoKey, &valuePtr);
	if (valuePtr != NULL) {
	    int infoLen;
	    (void) Tcl_GetStringFromObj(valuePtr, &infoLen);
	    if (infoLen) {
		if (iPtr->errorInfo) {
		    Tcl_DecrRefCount(iPtr->errorInfo);
		}
		iPtr->errorInfo = valuePtr;
		Tcl_IncrRefCount(iPtr->errorInfo);
		iPtr->flags |= ERR_ALREADY_LOGGED;
	    }
	}
	Tcl_DictObjGet(NULL, iPtr->returnOpts,
		iPtr->returnErrorcodeKey, &valuePtr);
	if (valuePtr != NULL) {
	    Tcl_SetObjErrorCode(interp, valuePtr);
	} else {
	    Tcl_SetErrorCode(interp, "NONE", NULL);
	}

	Tcl_DictObjGet(NULL, iPtr->returnOpts,
		iPtr->returnErrorlineKey, &valuePtr);
	if (valuePtr != NULL) {
	    Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
	}
    }
    if (level != 0) {
	iPtr->returnLevel = level;
	iPtr->returnCode = code;
	return TCL_RETURN;
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclMergeReturnOptions --
 *
 *	Parses, checks, and stores the options to the [return] command.
 *
 * Results:
 *	Returns TCL_ERROR is any of the option values are invalid.
 *	Otherwise, returns TCL_OK, and writes the returnOpts, code,
 *	and level values to the pointers provided.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */

int
TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
    Tcl_Obj **optionsPtrPtr;	/* If not NULL, points to space for a
				 * (Tcl_Obj *) where the pointer to the
				 * merged return options dictionary should
				 * be written */
    int *codePtr;		/* If not NULL, points to space where the
				 * -code value should be written */
    int *levelPtr;		/* If not NULL, points to space where the
				 * -level value should be written */
{
    Interp *iPtr = (Interp *) interp;
    int code=TCL_OK;
    int level = 1;
    Tcl_Obj *valuePtr;
    Tcl_Obj *returnOpts = Tcl_NewObj();

    for (;  objc > 1;  objv += 2, objc -= 2) {
	int optLen;
	CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen);
	int compareLen;
	CONST char *compare = Tcl_GetStringFromObj(
		iPtr->returnOptionsKey, &compareLen);

	if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) {
	    Tcl_DictSearch search;
	    int done = 0;
	    Tcl_Obj *keyPtr;
	    Tcl_Obj *dict = objv[1];

	    nestedOptions:
	    if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict,
		    &search, &keyPtr, &valuePtr, &done)) {
		/* Value is not a legal dictionary */
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "bad ",
			compare, " value: expected dictionary but got \"",
			TclGetString(objv[1]), "\"", (char *) NULL);
		goto error;
	    }

	    while (!done) {
		Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
	    }

	    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnOptionsKey, &valuePtr);
	    if (valuePtr != NULL) {
		dict = valuePtr;
		Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnOptionsKey);
		goto nestedOptions;
	    }

	} else {
	    Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]);
	}
    }

    /* Check for bogus -code value */
    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr);
    if ((valuePtr != NULL) 
	    && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
	static CONST char *returnCodes[] = {
	    "ok", "error", "return", "break", "continue", NULL
	};

	if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
		NULL, TCL_EXACT, &code)) {
	    /* Value is not a legal return code */
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad completion code \"",
		    TclGetString(valuePtr),
		    "\": must be ok, error, return, break, ",
		    "continue, or an integer", (char *) NULL);
	    goto error;
	}
	Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnCodeKey);
    }

    /* Check for bogus -level value */
    Tcl_DictObjGet(NULL, returnOpts, iPtr->returnLevelKey, &valuePtr);
    if (valuePtr != NULL) {
	if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) 
		|| (level < 0)) {
	    /* Value is not a legal level */
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "bad -level value: ",
		"expected non-negative integer but got \"",
		TclGetString(valuePtr), "\"", (char *) NULL);
	    goto error;
	}
	Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnLevelKey);
    }

    /* 
     * Convert [return -code return -level X] to
     * [return -code ok -level X+1]
     */
    if (code == TCL_RETURN) {
	level++;
	code = TCL_OK;
    }

    if (codePtr != NULL) {
	*codePtr = code;
    }
    if (levelPtr != NULL) {
	*levelPtr = level;
    }
    if (optionsPtrPtr == NULL) {
	/* Not passing back the options (?!), so clean them up */
	Tcl_DecrRefCount(returnOpts);
    } else {
	*optionsPtrPtr = returnOpts;
    }
    return TCL_OK;

error:
    Tcl_DecrRefCount(returnOpts);
    return TCL_ERROR;
}

/*
 *-------------------------------------------------------------------------
 *
 * TclGetReturnOptions --
 *
 *	Packs up the interp state into a dictionary of return options.
 *
 * Results:
 *	A dictionary of return options.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

Tcl_Obj *
TclGetReturnOptions(interp, result)
    Tcl_Interp *interp;
    int result;
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *options;

    if (iPtr->returnOpts) {
	options = Tcl_DuplicateObj(iPtr->returnOpts);
    } else {
	options = Tcl_NewObj();
    }

    if (result == TCL_RETURN) {
	Tcl_DictObjPut(NULL, options,
		iPtr->returnCodeKey, Tcl_NewIntObj(iPtr->returnCode));
	Tcl_DictObjPut(NULL, options,
		iPtr->returnLevelKey, Tcl_NewIntObj(iPtr->returnLevel));
    } else {
	Tcl_DictObjPut(NULL, options,
		iPtr->returnCodeKey, Tcl_NewIntObj(result));
	Tcl_DictObjPut(NULL, options,
		iPtr->returnLevelKey, Tcl_NewIntObj(0));
    }

    if (result == TCL_ERROR) {
	/*
	 * When result was an error, fill in any missing values
	 * for -errorinfo, -errorcode, and -errorline
	 */
	Tcl_DictObjPut(NULL, options,
		iPtr->returnErrorinfoKey, iPtr->errorInfo);
	Tcl_DictObjPut(NULL, options,
		iPtr->returnErrorcodeKey, iPtr->errorCode);
	Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey,
		Tcl_NewIntObj(iPtr->errorLine));
    }
    return options;
}

/*
 *-------------------------------------------------------------------------
 *
 * TclSetReturnOptions --
 *
 *	Accepts an interp and a  dictionary of return options, and sets
 *	the return options of the interp to match the dictionary.
 *
 * Results:
 *	A standard status code.  Usually TCL_OK, but TCL_ERROR if an
 *	invalid option value was found in the dictionary.  If a -level
 *	value of 0 is in the dictionary, then the -code value in the
 *	dictionary will be returned (TCL_OK default).
 *
 * Side effects:
 *	Sets the state of the interp.
 *
 *-------------------------------------------------------------------------
 */

int
TclSetReturnOptions(interp, options)
    Tcl_Interp *interp;
    Tcl_Obj *options;
{
    int objc, level, code;
    Tcl_Obj **objv, *mergedOpts;

    if (TCL_ERROR == Tcl_ListObjGetElements(interp, options, &objc, &objv)
	    || (objc % 2)) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "expected dict but got \"",
		Tcl_GetString(options), "\"", NULL);
	code = TCL_ERROR;
    } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
	    &mergedOpts, &code, &level)) {
	code = TCL_ERROR;
    } else {
	code = TclProcessReturn(interp, code, level, mergedOpts);
    }

    Tcl_DecrRefCount(options);
    return code;
}

/*
 *-------------------------------------------------------------------------
 *
 * 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 errorInfo field may be transferred to the
 *	target's errorInfo field, and the source's errorCode field may be
 *	transferred to the target's errorCode field.
 *
 * 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 *siPtr = (Interp *) sourceInterp;
    Interp *tiPtr = (Interp *) targetInterp;

    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.
	 */

        if ((siPtr->flags & ERR_ALREADY_LOGGED) == 0) {
            Tcl_AddErrorInfo(sourceInterp, "");
        }
        siPtr->flags &= ~(ERR_ALREADY_LOGGED);
        
        Tcl_ResetResult(targetInterp);
        
	if (siPtr->errorInfo) {
	    tiPtr->errorInfo = siPtr->errorInfo;
	    Tcl_IncrRefCount(tiPtr->errorInfo);
	}

	if (siPtr->errorCode) {
	    Tcl_SetObjErrorCode(targetInterp, siPtr->errorCode);
	}
    }

    /* This may need examination for safety */
    if (tiPtr->returnOpts ) {
	Tcl_DecrRefCount(tiPtr->returnOpts );
    }
    tiPtr->returnOpts = siPtr->returnOpts;
    if (tiPtr->returnOpts ) {
	Tcl_IncrRefCount(tiPtr->returnOpts );
    }

    Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
    Tcl_ResetResult(sourceInterp);
}