source: downloads/tcl8.5.2/generic/tclResult.c @ 64

/*
 * 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.47 2008/03/07 22:42:49 andreas_kupries Exp $
 */

#include "tclInt.h"

/*
 * Indices of the standard return options dictionary keys.
 */

enum returnKeys {
    KEY_CODE,   KEY_ERRORCODE,  KEY_ERRORINFO,  KEY_ERRORLINE,
    KEY_LEVEL,  KEY_OPTIONS,    KEY_LAST
};

/*
 * Function prototypes for local functions in this file:
 */

static Tcl_Obj **       GetKeys(void);
static void             ReleaseKeys(ClientData clientData);
static void             ResetObjResult(Interp *iPtr);
static void             SetupAppendBuffer(Interp *iPtr, int newSpace);

/*
 * This structure is used to take a snapshot of the interpreter state in
 * Tcl_SaveInterpState. 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 the */
    int returnLevel;            /* corresponding field of the Interp */
    int returnCode;             /* struct. These fields taken together are */
    Tcl_Obj *errorInfo;         /* the "state" of the interp. */
    Tcl_Obj *errorCode;
    Tcl_Obj *returnOpts;
    Tcl_Obj *objResult;
} InterpState;

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

Tcl_InterpState
Tcl_SaveInterpState(
    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 (Tcl_InterpState) statePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RestoreInterpState --
 *
 *      Accepts an interp and a token previously returned by
 *      Tcl_SaveInterpState. Restore the state of the interp to what it was at
 *      the time of the Tcl_SaveInterpState call.
 *
 * Results:
 *      Returns the status value originally passed in to Tcl_SaveInterpState.
 *
 * Side effects:
 *      Restores the interp state and frees memory held by token.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RestoreInterpState(
    Tcl_Interp *interp,         /* Interpreter's state to be restored. */
    Tcl_InterpState 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);
    Tcl_DiscardInterpState(state);
    return status;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DiscardInterpState --
 *
 *      Accepts a token previously returned by Tcl_SaveInterpState. Frees the
 *      memory it uses.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Frees memory.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DiscardInterpState(
    Tcl_InterpState 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(
    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(
    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 function must be
 *      called to discard it, or the memory will be lost.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DiscardResult(
    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 "result" to be the Tcl return value.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      interp->result is left pointing either to "result" or to a copy of it.
 *      Also, the object result is reset.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetResult(
    Tcl_Interp *interp,         /* Interpreter with which to associate the
                                 * return value. */
    register char *result,      /* 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 (result == NULL) {
        iPtr->resultSpace[0] = 0;
        iPtr->result = iPtr->resultSpace;
        iPtr->freeProc = 0;
    } else if (freeProc == TCL_VOLATILE) {
        length = strlen(result);
        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, result);
    } else {
        iPtr->result = result;
        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(
    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(
    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 function 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(
    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(
    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);

    /*
     * Strictly we should call Tcl_GetStringResult(interp) here to make sure
     * that interp->result is correct according to the old contract, but that
     * makes the performance of much code (e.g. in Tk) absolutely awful. So we
     * leave it out; code that really wants interp->result can just insert the
     * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion]
     */

#ifdef USE_DIRECT_INTERP_RESULT_ACCESS
    /*
     * 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);
#endif /* USE_DIRECT_INTERP_RESULT_ACCESS */
}

/*
 *----------------------------------------------------------------------
 *
 * 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_Interp *interp, ...)
{
    va_list argList;

    va_start(argList, interp);
    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(
    Tcl_Interp *interp,         /* Interpreter whose result is to be
                                 * extended. */
    CONST char *element)        /* 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(element, &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(element, dst, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * SetupAppendBuffer --
 *
 *      This function 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(
    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 function 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 function 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(
    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 function 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(
    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 */
        if (iPtr->flags & ERR_LEGACY_COPY) {
            Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
                    iPtr->errorCode, TCL_GLOBAL_ONLY);
        }
        Tcl_DecrRefCount(iPtr->errorCode);
        iPtr->errorCode = NULL;
    }
    if (iPtr->errorInfo) {
        /* Legacy support */
        if (iPtr->flags & ERR_LEGACY_COPY) {
            Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
                    iPtr->errorInfo, TCL_GLOBAL_ONLY);
        }
        Tcl_DecrRefCount(iPtr->errorInfo);
        iPtr->errorInfo = NULL;
    }
    iPtr->returnLevel = 1;
    iPtr->returnCode = TCL_OK;
    if (iPtr->returnOpts) {
        Tcl_DecrRefCount(iPtr->returnOpts);
        iPtr->returnOpts = NULL;
    }
    iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY);
}

/*
 *----------------------------------------------------------------------
 *
 * ResetObjResult --
 *
 *      Function 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(
    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 != tclEmptyStringRep) {
        if (objResultPtr->bytes != NULL) {
            ckfree((char *) objResultPtr->bytes);
        }
        objResultPtr->bytes = tclEmptyStringRep;
        objResultPtr->length = 0;
        TclFreeIntRep(objResultPtr);
        objResultPtr->typePtr = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetErrorCodeVA --
 *
 *      This function 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 function, in a list form with each argument becoming
 *      one element of the list.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetErrorCodeVA(
    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 function 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 function, in a list form with each argument becoming
 *      one element of the list.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetErrorCode(
    Tcl_Interp *interp, ...)
{
    va_list argList;

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

    va_start(argList, interp);
    Tcl_SetErrorCodeVA(interp, argList);
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjErrorCode --
 *
 *      This function 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(
    Tcl_Interp *interp,
    Tcl_Obj *errorObjPtr)
{
    Interp *iPtr = (Interp *) interp;

    if (iPtr->errorCode) {
        Tcl_DecrRefCount(iPtr->errorCode);
    }
    iPtr->errorCode = errorObjPtr;
    Tcl_IncrRefCount(iPtr->errorCode);
}

/*
 *----------------------------------------------------------------------
 *
 * GetKeys --
 *
 *      Returns a Tcl_Obj * array of the standard keys used in the return
 *      options dictionary.
 *
 *      Broadly sharing one copy of these key values helps with both memory
 *      efficiency and dictionary lookup times.
 *
 * Results:
 *      A Tcl_Obj * array.
 *
 * Side effects:
 *      First time called in a thread, creates the keys (allocating memory)
 *      and arranges for their cleanup at thread exit.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj **
GetKeys(void)
{
    static Tcl_ThreadDataKey returnKeysKey;
    Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey,
            (int) (KEY_LAST * sizeof(Tcl_Obj *)));

    if (keys[0] == NULL) {
        /*
         * First call in this thread, create the keys...
         */

        int i;

        TclNewLiteralStringObj(keys[KEY_CODE],      "-code");
        TclNewLiteralStringObj(keys[KEY_ERRORCODE], "-errorcode");
        TclNewLiteralStringObj(keys[KEY_ERRORINFO], "-errorinfo");
        TclNewLiteralStringObj(keys[KEY_ERRORLINE], "-errorline");
        TclNewLiteralStringObj(keys[KEY_LEVEL],     "-level");
        TclNewLiteralStringObj(keys[KEY_OPTIONS],   "-options");

        for (i = KEY_CODE; i < KEY_LAST; i++) {
            Tcl_IncrRefCount(keys[i]);
        }

        /*
         * ... and arrange for their clenaup.
         */

        Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys);
    }
    return keys;
}

/*
 *----------------------------------------------------------------------
 *
 * ReleaseKeys --
 *
 *      Called as a thread exit handler to cleanup return options dictionary
 *      keys.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Frees memory.
 *
 *----------------------------------------------------------------------
 */

static void
ReleaseKeys(
    ClientData clientData)
{
    Tcl_Obj **keys = (Tcl_Obj **)clientData;
    int i;

    for (i = KEY_CODE; i < KEY_LAST; i++) {
        Tcl_DecrRefCount(keys[i]);
        keys[i] = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    Tcl_Interp *interp,
    int code,
    int level,
    Tcl_Obj *returnOpts)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *valuePtr;
    Tcl_Obj **keys = GetKeys();

    /*
     * 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) {
        if (iPtr->errorInfo) {
            Tcl_DecrRefCount(iPtr->errorInfo);
            iPtr->errorInfo = NULL;
        }
        Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr);
        if (valuePtr != NULL) {
            int infoLen;

            (void) TclGetStringFromObj(valuePtr, &infoLen);
            if (infoLen) {
                iPtr->errorInfo = valuePtr;
                Tcl_IncrRefCount(iPtr->errorInfo);
                iPtr->flags |= ERR_ALREADY_LOGGED;
            }
        }
        Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr);
        if (valuePtr != NULL) {
            Tcl_SetObjErrorCode(interp, valuePtr);
        } else {
            Tcl_SetErrorCode(interp, "NONE", NULL);
        }

        Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr);
        if (valuePtr != NULL) {
            TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
        }
    }
    if (level != 0) {
        iPtr->returnLevel = level;
        iPtr->returnCode = code;
        return TCL_RETURN;
    }
    if (code == TCL_ERROR) {
        iPtr->flags |= ERR_LEGACY_COPY;
    }
    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(
    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 */
{
    int code=TCL_OK;
    int level = 1;
    Tcl_Obj *valuePtr;
    Tcl_Obj *returnOpts = Tcl_NewObj();
    Tcl_Obj **keys = GetKeys();

    for (;  objc > 1;  objv += 2, objc -= 2) {
        int optLen;
        CONST char *opt = TclGetStringFromObj(objv[0], &optLen);
        int compareLen;
        CONST char *compare =
                TclGetStringFromObj(keys[KEY_OPTIONS], &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]), "\"", NULL);
                goto error;
            }

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

            Tcl_DictObjGet(NULL, returnOpts, keys[KEY_OPTIONS], &valuePtr);
            if (valuePtr != NULL) {
                dict = valuePtr;
                Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_OPTIONS]);
                goto nestedOptions;
            }

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

    /*
     * Check for bogus -code value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
    if ((valuePtr != NULL)
            && (TCL_ERROR == TclGetIntFromObj(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", NULL);
            goto error;
        }
    }
    if (valuePtr != NULL) {
        Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
    }

    /*
     * Check for bogus -level value.
     */

    Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr);
    if (valuePtr != NULL) {
        if ((TCL_ERROR == TclGetIntFromObj(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), "\"", NULL);
            goto error;
        }
        Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]);
    }

    /*
     * 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;
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_GetReturnOptions --
 *
 *      Packs up the interp state into a dictionary of return options.
 *
 * Results:
 *      A dictionary of return options.
 *
 * Side effects:
 *      None.
 *
 *-------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetReturnOptions(
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *options;
    Tcl_Obj **keys = GetKeys();

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

    if (result == TCL_RETURN) {
        Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
                Tcl_NewIntObj(iPtr->returnCode));
        Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
                Tcl_NewIntObj(iPtr->returnLevel));
    } else {
        Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
                Tcl_NewIntObj(result));
        Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
                Tcl_NewIntObj(0));
    }

    if (result == TCL_ERROR) {
        Tcl_AddObjErrorInfo(interp, "", -1);
    }
    if (iPtr->errorCode) {
        Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
    }
    if (iPtr->errorInfo) {
        Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
        Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
                Tcl_NewIntObj(iPtr->errorLine));
    }
    return options;
}

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_SetReturnOptions --
 *
 *      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
Tcl_SetReturnOptions(
    Tcl_Interp *interp,
    Tcl_Obj *options)
{
    int objc, level, code;
    Tcl_Obj **objv, *mergedOpts;

    Tcl_IncrRefCount(options);
    if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
            || (objc % 2)) {
        Tcl_ResetResult(interp);
        Tcl_AppendResult(interp, "expected dict but got \"",
                TclGetString(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(
    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 *tiPtr = (Interp *) targetInterp;
    Interp *siPtr = (Interp *) sourceInterp;

    if (sourceInterp == targetInterp) {
        return;
    }

    if (result == TCL_OK && siPtr->returnOpts == NULL) {
        /*
         * Special optimization for the common case of normal command return
         * code and no explicit return options.
         */

        if (tiPtr->returnOpts) {
            Tcl_DecrRefCount(tiPtr->returnOpts);
            tiPtr->returnOpts = NULL;
        }
    } else {
        Tcl_SetReturnOptions(targetInterp,
                Tcl_GetReturnOptions(sourceInterp, result));
        tiPtr->flags &= ~(ERR_ALREADY_LOGGED);
    }
    Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
    Tcl_ResetResult(sourceInterp);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */