diff options
Diffstat (limited to 'generic/tclResult.c')
| -rw-r--r-- | generic/tclResult.c | 1431 |
1 files changed, 367 insertions, 1064 deletions
diff --git a/generic/tclResult.c b/generic/tclResult.c index 4443cc1..6dbdd90 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1,225 +1,39 @@ -/* +/* * 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. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #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_ERRORSTACK, 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; - Tcl_Obj *errorStack; - int resetErrorStack; -} 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 = 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; - statePtr->errorStack = iPtr->errorStack; - statePtr->resetErrorStack = iPtr->resetErrorStack; - 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); - } - if (statePtr->errorStack) { - Tcl_IncrRefCount(statePtr->errorStack); - } - 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; - iPtr->resetErrorStack = statePtr->resetErrorStack; - 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->errorStack) { - Tcl_DecrRefCount(iPtr->errorStack); - } - iPtr->errorStack = statePtr->errorStack; - if (iPtr->errorStack) { - Tcl_IncrRefCount(iPtr->errorStack); - } - 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. - * - *---------------------------------------------------------------------- + * Function prototypes for local procedures in this file: */ -void -Tcl_DiscardInterpState( - Tcl_InterpState state) /* saved interpreter state */ -{ - InterpState *statePtr = (InterpState *) state; +static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); +static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, + int newSpace)); - if (statePtr->errorInfo) { - Tcl_DecrRefCount(statePtr->errorInfo); - } - if (statePtr->errorCode) { - Tcl_DecrRefCount(statePtr->errorCode); - } - if (statePtr->returnOpts) { - Tcl_DecrRefCount(statePtr->returnOpts); - } - if (statePtr->errorStack) { - Tcl_DecrRefCount(statePtr->errorStack); - } - Tcl_DecrRefCount(statePtr->objResult); - ckfree(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. + * 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. + * Once a snapshot is saved, it must be restored by calling + * Tcl_RestoreResult, or discarded by calling + * Tcl_DiscardResult. * * Results: * None. @@ -231,24 +45,24 @@ Tcl_DiscardInterpState( */ void -Tcl_SaveResult( - Tcl_Interp *interp, /* Interpreter to save. */ - Tcl_SavedResult *statePtr) /* Pointer to state structure. */ +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. + * 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); + iPtr->objResultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(iPtr->objResultPtr); /* - * Save the string result. + * Save the string result. */ statePtr->freeProc = iPtr->freeProc; @@ -291,23 +105,23 @@ Tcl_SaveResult( * * 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. + * 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. + * None. * * Side effects: - * Restores the interpreter result. + * Restores the interpreter result. * *---------------------------------------------------------------------- */ void -Tcl_RestoreResult( - Tcl_Interp *interp, /* Interpreter being restored. */ - Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ +Tcl_RestoreResult(interp, statePtr) + Tcl_Interp* interp; /* Interpreter being restored. */ + Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */ { Interp *iPtr = (Interp *) interp; @@ -331,7 +145,7 @@ Tcl_RestoreResult( */ if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); + ckfree((char *)iPtr->appendResult); } iPtr->appendResult = statePtr->appendResult; @@ -359,22 +173,23 @@ Tcl_RestoreResult( * * 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. + * 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. + * None. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ void -Tcl_DiscardResult( - Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ +Tcl_DiscardResult(statePtr) + Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */ { TclDecrRefCount(statePtr->objResultPtr); @@ -384,7 +199,7 @@ Tcl_DiscardResult( if (statePtr->freeProc == TCL_DYNAMIC) { ckfree(statePtr->result); } else { - statePtr->freeProc(statePtr->result); + (*statePtr->freeProc)(statePtr->result); } } } @@ -394,63 +209,63 @@ Tcl_DiscardResult( * * Tcl_SetResult -- * - * Arrange for "result" to be the Tcl return value. + * Arrange for "string" 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. + * 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( - Tcl_Interp *interp, /* Interpreter with which to associate the +Tcl_SetResult(interp, string, freeProc) + 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. */ + 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 (result == NULL) { + if (string == NULL) { iPtr->resultSpace[0] = 0; iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } else if (freeProc == TCL_VOLATILE) { - int length = strlen(result); - + length = strlen(string); if (length > TCL_RESULT_SIZE) { - iPtr->result = ckalloc(length + 1); + iPtr->result = (char *) ckalloc((unsigned) length+1); iPtr->freeProc = TCL_DYNAMIC; } else { iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } - memcpy(iPtr->result, result, (unsigned) length+1); + strcpy(iPtr->result, string); } else { - iPtr->result = (char *) result; + 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 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); + (*oldFreeProc)(oldResult); } } @@ -478,22 +293,20 @@ Tcl_SetResult( *---------------------------------------------------------------------- */ -const char * -Tcl_GetStringResult( - register Tcl_Interp *interp)/* Interpreter whose result to return. */ +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 the string result is empty, move the object result to the + * string result, then reset the object result. */ - - Interp *iPtr = (Interp *) interp; - - if (*(iPtr->result) == 0) { + + if (*(interp->result) == 0) { Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); + TCL_VOLATILE); } - return iPtr->result; + return interp->result; } /* @@ -507,20 +320,22 @@ Tcl_GetStringResult( * 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. + * 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 +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 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; @@ -529,10 +344,10 @@ Tcl_SetObjResult( 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. + * We wait until the end to release the old object result, in case + * we are setting the result to itself. */ - + TclDecrRefCount(oldObjResult); /* @@ -543,7 +358,7 @@ Tcl_SetObjResult( if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); } else { - iPtr->freeProc(iPtr->result); + (*iPtr->freeProc)(iPtr->result); } iPtr->freeProc = 0; } @@ -557,46 +372,46 @@ Tcl_SetObjResult( * 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. + * 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. + * 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( - Tcl_Interp *interp) /* Interpreter whose result to return. */ +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 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)(iPtr->result); } iPtr->freeProc = 0; } @@ -611,51 +426,110 @@ Tcl_GetObjResult( * * Tcl_AppendResultVA -- * - * Append a variable number of strings onto the interpreter's result. + * 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). + * 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. + * If the string result is empty, the object result is moved to the + * string result, then the object result is reset. * *---------------------------------------------------------------------- */ void -Tcl_AppendResultVA( - Tcl_Interp *interp, /* Interpreter with which to associate the +Tcl_AppendResultVA (interp, argList) + Tcl_Interp *interp; /* Interpreter with which to associate the * return value. */ - va_list argList) /* Variable argument list. */ + va_list argList; /* Variable argument list. */ { - Tcl_Obj *objPtr = Tcl_GetObjResult(interp); +#define STATIC_LIST_SIZE 16 + Interp *iPtr = (Interp *) interp; + char *string, *static_list[STATIC_LIST_SIZE]; + char **args = static_list; + int nargs_space = STATIC_LIST_SIZE; + int nargs, newSpace, i; + + /* + * If the string result is empty, move the object result to the + * string result, then reset the object result. + */ - if (Tcl_IsShared(objPtr)) { - objPtr = Tcl_DuplicateObj(objPtr); + 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 + * and save pointers to the arguments in the args array, + * reallocating as necessary. + */ + + nargs = 0; + newSpace = 0; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + if (nargs >= nargs_space) { + /* + * Expand the args buffer + */ + nargs_space += STATIC_LIST_SIZE; + if (args == static_list) { + args = (void *)ckalloc(nargs_space * sizeof(char *)); + for (i = 0; i < nargs; ++i) { + args[i] = static_list[i]; + } + } else { + args = (void *)ckrealloc((void *)args, + nargs_space * sizeof(char *)); + } + } + newSpace += strlen(string); + args[nargs++] = string; } - 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] + * If the append buffer isn't already setup and large enough to hold + * the new data, set it up. */ -#ifdef USE_INTERP_RESULT + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, newSpace); + } + /* - * Ensure that the interp->result is legal so old Tcl 7.* code still - * works. There's still embarrasingly much of it about... + * Now go through all the argument strings again, copying them into the + * buffer. */ - (void) Tcl_GetStringResult(interp); -#endif /* USE_INTERP_RESULT */ + for (i = 0; i < nargs; ++i) { + string = args[i]; + strcpy(iPtr->appendResult + iPtr->appendUsed, string); + iPtr->appendUsed += strlen(string); + } + + /* + * If we had to allocate a buffer from the heap, + * free it now. + */ + + if (args != static_list) { + ckfree((void *)args); + } +#undef STATIC_LIST_SIZE } /* @@ -663,29 +537,30 @@ Tcl_AppendResultVA( * * Tcl_AppendResult -- * - * Append a variable number of strings onto the interpreter's result. + * 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). + * 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. + * 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_Interp *interp, ...) +Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) { + Tcl_Interp *interp; va_list argList; - va_start(argList, interp); + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); Tcl_AppendResultVA(interp, argList); va_end(argList); } @@ -702,10 +577,10 @@ Tcl_AppendResult( * 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 " {". + * 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. @@ -714,11 +589,11 @@ Tcl_AppendResult( */ void -Tcl_AppendElement( - Tcl_Interp *interp, /* Interpreter whose result is to be +Tcl_AppendElement(interp, string) + Tcl_Interp *interp; /* Interpreter whose result is to be * extended. */ - const char *element) /* String to convert to list element and add - * to result. */ + CONST char *string; /* String to convert to list element and + * add to result. */ { Interp *iPtr = (Interp *) interp; char *dst; @@ -726,27 +601,30 @@ Tcl_AppendElement( int flags; /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. + * If the string result is empty, move the object result to the + * string result, then reset the object result. */ - (void) Tcl_GetStringResult(interp); + 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. + * See how much space is needed, and grow the append buffer if + * needed to accommodate the list element. */ - size = Tcl_ScanElement(element, &flags) + 1; + 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); + 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. + * 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; @@ -754,16 +632,8 @@ Tcl_AppendElement( 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); + iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); } /* @@ -771,10 +641,10 @@ Tcl_AppendElement( * * 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. + * 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. @@ -786,10 +656,10 @@ Tcl_AppendElement( */ 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. */ +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; @@ -801,9 +671,9 @@ SetupAppendBuffer( 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 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) { @@ -815,13 +685,13 @@ SetupAppendBuffer( } 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. + * 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; @@ -831,7 +701,7 @@ SetupAppendBuffer( } else { totalSpace *= 2; } - new = ckalloc(totalSpace); + new = (char *) ckalloc((unsigned) totalSpace); strcpy(new, iPtr->result); if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); @@ -841,7 +711,7 @@ SetupAppendBuffer( } else if (iPtr->result != iPtr->appendResult) { strcpy(iPtr->appendResult, iPtr->result); } - + Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } @@ -851,9 +721,9 @@ SetupAppendBuffer( * * Tcl_FreeResult -- * - * This function frees up the memory associated with an interpreter's + * 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 function is about to + * Tcl_FreeResult is most commonly used when a procedure is about to * replace one result value with another. * * Results: @@ -861,28 +731,28 @@ SetupAppendBuffer( * * 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. + * 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. */ +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)(iPtr->result); } iPtr->freeProc = 0; } - + ResetObjResult(iPtr); } @@ -891,23 +761,24 @@ Tcl_FreeResult( * * Tcl_ResetResult -- * - * This function resets both the interpreter's string and object results. + * 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. + * 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. */ +Tcl_ResetResult(interp) + register Tcl_Interp *interp; /* Interpreter for which to clear result. */ { register Interp *iPtr = (Interp *) interp; @@ -916,38 +787,13 @@ Tcl_ResetResult( if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); } else { - iPtr->freeProc(iPtr->result); + (*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->resetErrorStack = 1; - 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); + iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); } /* @@ -955,22 +801,22 @@ Tcl_ResetResult( * * ResetObjResult -- * - * Function used to reset an interpreter's Tcl result object. + * 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. + * 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 +ResetObjResult(iPtr) + register Interp *iPtr; /* Points to the interpreter whose result * object should be reset. */ { register Tcl_Obj *objResultPtr = iPtr->objResultPtr; @@ -981,14 +827,17 @@ ResetObjResult( Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; } else { - if (objResultPtr->bytes != tclEmptyStringRep) { - if (objResultPtr->bytes) { - ckfree(objResultPtr->bytes); - } - objResultPtr->bytes = tclEmptyStringRep; - objResultPtr->length = 0; + 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); } - TclFreeIntRep(objResultPtr); + objResultPtr->typePtr = (Tcl_ObjType *) NULL; } } @@ -997,41 +846,48 @@ ResetObjResult( * * Tcl_SetErrorCodeVA -- * - * This function is called to record machine-readable information about - * an error that is about to be returned. + * 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 function, in a list form with each argument becoming - * one element of the list. + * 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( - Tcl_Interp *interp, /* Interpreter in which to set errorCode */ - va_list argList) /* Variable argument list. */ +Tcl_SetErrorCodeVA (interp, argList) + Tcl_Interp *interp; /* Interpreter in which to access the errorCode + * variable. */ + va_list argList; /* Variable argument list. */ { - Tcl_Obj *errorObj = Tcl_NewObj(); + char *string; + int flags; + Interp *iPtr = (Interp *) interp; /* - * Scan through the arguments one at a time, appending them to the - * errorCode field as list elements. + * Scan through the arguments one at a time, appending them to + * $errorCode as list elements. */ + flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; while (1) { - char *elem = va_arg(argList, char *); - - if (elem == NULL) { + string = va_arg(argList, char *); + if (string == NULL) { break; } - Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1)); + (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, string, flags); + flags |= TCL_APPEND_VALUE; } - Tcl_SetObjErrorCode(interp, errorObj); + iPtr->flags |= ERROR_CODE_SET; } /* @@ -1039,32 +895,34 @@ Tcl_SetErrorCodeVA( * * Tcl_SetErrorCode -- * - * This function is called to record machine-readable information about - * an error that is about to be returned. + * 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 function, in a list form with each argument becoming - * one element of the list. + * 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_Interp *interp, ...) +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. + * Scan through the arguments one at a time, appending them to + * $errorCode as list elements. */ - va_start(argList, interp); + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); Tcl_SetErrorCodeVA(interp, argList); va_end(argList); } @@ -1074,671 +932,116 @@ Tcl_SetErrorCode( * * 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. + * 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( - Tcl_Interp *interp, - Tcl_Obj *errorObjPtr) -{ - Interp *iPtr = (Interp *) interp; - - if (iPtr->errorCode) { - Tcl_DecrRefCount(iPtr->errorCode); - } - iPtr->errorCode = errorObjPtr; - Tcl_IncrRefCount(iPtr->errorCode); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetErrorLine -- - * - * Results: - * - * Side effects: - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetErrorLine( - Tcl_Interp *interp) -{ - return ((Interp *) interp)->errorLine; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetErrorLine -- - * - * Results: - * - * 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_SetErrorLine( - Tcl_Interp *interp, - int value) +Tcl_SetObjErrorCode(interp, errorObjPtr) + Tcl_Interp *interp; + Tcl_Obj *errorObjPtr; { - ((Interp *) interp)->errorLine = value; -} - -/* - *---------------------------------------------------------------------- - * - * 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_ERRORSTACK],"-errorstack"); - 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, 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 = 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_ERRORSTACK], &valuePtr); - if (valuePtr != NULL) { - int len, valueObjc; - Tcl_Obj **valueObjv; - - if (Tcl_IsShared(iPtr->errorStack)) { - Tcl_Obj *newObj; - - newObj = Tcl_DuplicateObj(iPtr->errorStack); - Tcl_DecrRefCount(iPtr->errorStack); - Tcl_IncrRefCount(newObj); - iPtr->errorStack = newObj; - } - /* - * List extraction done after duplication to avoid moving the rug - * if someone does [return -errorstack [info errorstack]] - */ - if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { - return TCL_ERROR; - } - iPtr->resetErrorStack = 0; - Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* reset while keeping the list intrep as much as possible */ - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv); - } - 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 if 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) && (memcmp(opt, compare, optLen) == 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); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", - 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) { - if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, valuePtr, &code)) { - goto error; - } - 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); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL); - goto error; - } - Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]); - } - - /* - * Check for bogus -errorcode value. - */ - - Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr); - if (valuePtr != NULL) { - int length; - - if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { - /* - * Value is not a list, which is illegal for -errorcode. - */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -errorcode value: " - "expected a list but got \"", - TclGetString(valuePtr), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE", - NULL); - goto error; - } - } - - /* - * Check for bogus -errorstack value. - */ - - Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr); - if (valuePtr != NULL) { - int length; - - if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { - /* - * Value is not a list, which is illegal for -errorstack. - */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -errorstack value: " - "expected a list but got \"", TclGetString(valuePtr), - "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", - NULL); - goto error; - } - if (length % 2) { - /* - * Errorstack must always be an even-sized list - */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "forbidden odd-sized list for -errorstack: \"", - TclGetString(valuePtr), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", - "ODDSIZEDLIST_ERRORSTACK", NULL); - goto error; - } - } - - /* - * 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); - Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack); - } - 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; -} - -/* - *------------------------------------------------------------------------- - * - * TclNoErrorStack -- - * - * Removes the -errorstack entry from an options dict to avoid reference cycles - * - * Results: - * The (unshared) argument options dict, modified in -place. - * - *------------------------------------------------------------------------- - */ - -Tcl_Obj * -TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options) -{ - Tcl_Obj **keys = GetKeys(); + Interp *iPtr; - Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]); - - return options; + iPtr = (Interp *) interp; + Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; } /* *------------------------------------------------------------------------- * - * Tcl_SetReturnOptions -- - * - * Accepts an interp and a dictionary of return options, and sets the - * return options of the interp to match the dictionary. + * TclTransferResult -- * - * 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). + * 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. * - * 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); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_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; -} - -/* - *------------------------------------------------------------------------- - * - * Tcl_TransferResult -- - * - * 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. + * 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. + * 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 -Tcl_TransferResult( - Tcl_Interp *sourceInterp, /* Interp whose result and error information - * should be moved to the target interp. - * After moving result, this interp's result +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 + 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. */ + 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; + Interp *iPtr; + Tcl_Obj *objPtr; if (sourceInterp == targetInterp) { return; } - if (result == TCL_OK && siPtr->returnOpts == NULL) { + if (result == TCL_ERROR) { /* - * Special optimization for the common case of normal command return - * code and no explicit return options. + * 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 (tiPtr->returnOpts) { - Tcl_DecrRefCount(tiPtr->returnOpts); - tiPtr->returnOpts = NULL; + 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); + if (objPtr) { + Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr, + TCL_GLOBAL_ONLY); + ((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS; } - } else { - Tcl_SetReturnOptions(targetInterp, - Tcl_GetReturnOptions(sourceInterp, result)); - tiPtr->flags &= ~(ERR_ALREADY_LOGGED); + + objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL, + TCL_GLOBAL_ONLY); + if (objPtr) { + Tcl_SetObjErrorCode(targetInterp, objPtr); + } + } + + ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode; Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); Tcl_ResetResult(sourceInterp); } - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil - * End: - */ |