summaryrefslogtreecommitdiffstats
path: root/generic/tclResult.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclResult.c')
-rw-r--r--generic/tclResult.c585
1 files changed, 387 insertions, 198 deletions
diff --git a/generic/tclResult.c b/generic/tclResult.c
index a575a40..2f2563a 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -7,8 +7,6 @@
*
* 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.29 2005/07/24 22:56:43 dkf Exp $
*/
#include "tclInt.h"
@@ -19,18 +17,17 @@
enum returnKeys {
KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE,
- KEY_LEVEL, KEY_OPTIONS, KEY_LAST
+ KEY_LEVEL, KEY_OPTIONS, KEY_ERRORSTACK, KEY_LAST
};
/*
* Function prototypes for local functions in this file:
*/
-static Tcl_Obj ** GetKeys _ANSI_ARGS_((void));
-static void ReleaseKeys _ANSI_ARGS_((ClientData clientData));
-static void ResetObjResult _ANSI_ARGS_((Interp *iPtr));
-static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
- int newSpace));
+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
@@ -47,6 +44,8 @@ typedef struct InterpState {
Tcl_Obj *errorCode;
Tcl_Obj *returnOpts;
Tcl_Obj *objResult;
+ Tcl_Obj *errorStack;
+ int resetErrorStack;
} InterpState;
/*
@@ -71,18 +70,20 @@ typedef struct InterpState {
*/
Tcl_InterpState
-Tcl_SaveInterpState(interp, status)
- Tcl_Interp* interp; /* Interpreter's state to be saved */
- int status; /* status code for current operation */
+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));
+ 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);
}
@@ -94,6 +95,9 @@ Tcl_SaveInterpState(interp, status)
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;
@@ -118,12 +122,12 @@ Tcl_SaveInterpState(interp, status)
*/
int
-Tcl_RestoreInterpState(interp, state)
- Tcl_Interp* interp; /* Interpreter's state to be restored*/
- Tcl_InterpState state; /* saved interpreter state */
+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;
+ Interp *iPtr = (Interp *) interp;
+ InterpState *statePtr = (InterpState *) state;
int status = statePtr->status;
iPtr->flags &= ~ERR_ALREADY_LOGGED;
@@ -131,6 +135,7 @@ Tcl_RestoreInterpState(interp, state)
iPtr->returnLevel = statePtr->returnLevel;
iPtr->returnCode = statePtr->returnCode;
+ iPtr->resetErrorStack = statePtr->resetErrorStack;
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
}
@@ -145,6 +150,13 @@ Tcl_RestoreInterpState(interp, state)
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);
}
@@ -175,10 +187,10 @@ Tcl_RestoreInterpState(interp, state)
*/
void
-Tcl_DiscardInterpState(state)
- Tcl_InterpState state; /* saved interpreter state */
+Tcl_DiscardInterpState(
+ Tcl_InterpState state) /* saved interpreter state */
{
- InterpState *statePtr = (InterpState *)state;
+ InterpState *statePtr = (InterpState *) state;
if (statePtr->errorInfo) {
Tcl_DecrRefCount(statePtr->errorInfo);
@@ -189,8 +201,11 @@ Tcl_DiscardInterpState(state)
if (statePtr->returnOpts) {
Tcl_DecrRefCount(statePtr->returnOpts);
}
+ if (statePtr->errorStack) {
+ Tcl_DecrRefCount(statePtr->errorStack);
+ }
Tcl_DecrRefCount(statePtr->objResult);
- ckfree((char*) statePtr);
+ ckfree(statePtr);
}
/*
@@ -215,10 +230,11 @@ Tcl_DiscardInterpState(state)
*----------------------------------------------------------------------
*/
+#undef Tcl_SaveResult
void
-Tcl_SaveResult(interp, statePtr)
- Tcl_Interp *interp; /* Interpreter to save. */
- Tcl_SavedResult *statePtr; /* Pointer to state structure. */
+Tcl_SaveResult(
+ Tcl_Interp *interp, /* Interpreter to save. */
+ Tcl_SavedResult *statePtr) /* Pointer to state structure. */
{
Interp *iPtr = (Interp *) interp;
@@ -289,10 +305,11 @@ Tcl_SaveResult(interp, statePtr)
*----------------------------------------------------------------------
*/
+#undef Tcl_RestoreResult
void
-Tcl_RestoreResult(interp, statePtr)
- Tcl_Interp* interp; /* Interpreter being restored. */
- Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
+Tcl_RestoreResult(
+ Tcl_Interp *interp, /* Interpreter being restored. */
+ Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */
{
Interp *iPtr = (Interp *) interp;
@@ -316,7 +333,7 @@ Tcl_RestoreResult(interp, statePtr)
*/
if (iPtr->appendResult != NULL) {
- ckfree((char *)iPtr->appendResult);
+ ckfree(iPtr->appendResult);
}
iPtr->appendResult = statePtr->appendResult;
@@ -357,20 +374,19 @@ Tcl_RestoreResult(interp, statePtr)
*----------------------------------------------------------------------
*/
+#undef Tcl_DiscardResult
void
-Tcl_DiscardResult(statePtr)
- Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
+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 == TCL_DYNAMIC) {
+ ckfree(statePtr->result);
} else if (statePtr->freeProc) {
- if (statePtr->freeProc == TCL_DYNAMIC) {
- ckfree(statePtr->result);
- } else {
- (*statePtr->freeProc)(statePtr->result);
- }
+ statePtr->freeProc(statePtr->result);
}
}
@@ -392,17 +408,16 @@ Tcl_DiscardResult(statePtr)
*/
void
-Tcl_SetResult(interp, result, freeProc)
- Tcl_Interp *interp; /* Interpreter with which to associate the
+Tcl_SetResult(
+ Tcl_Interp *interp, /* Interpreter with which to associate the
* return value. */
- register char *result; /* Value to be returned. If NULL, the result
+ 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_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;
@@ -411,17 +426,18 @@ Tcl_SetResult(interp, result, freeProc)
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
} else if (freeProc == TCL_VOLATILE) {
- length = strlen(result);
+ int length = strlen(result);
+
if (length > TCL_RESULT_SIZE) {
- iPtr->result = (char *) ckalloc((unsigned) length+1);
+ iPtr->result = ckalloc(length + 1);
iPtr->freeProc = TCL_DYNAMIC;
} else {
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
}
- strcpy(iPtr->result, result);
+ memcpy(iPtr->result, result, (unsigned) length+1);
} else {
- iPtr->result = result;
+ iPtr->result = (char *) result;
iPtr->freeProc = freeProc;
}
@@ -435,7 +451,7 @@ Tcl_SetResult(interp, result, freeProc)
if (oldFreeProc == TCL_DYNAMIC) {
ckfree(oldResult);
} else {
- (*oldFreeProc)(oldResult);
+ oldFreeProc(oldResult);
}
}
@@ -463,20 +479,22 @@ Tcl_SetResult(interp, result, freeProc)
*----------------------------------------------------------------------
*/
-CONST char *
-Tcl_GetStringResult(interp)
- register Tcl_Interp *interp;/* Interpreter whose result to return. */
+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) {
+ Interp *iPtr = (Interp *) interp;
+
+ if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
- return interp->result;
+ return iPtr->result;
}
/*
@@ -499,10 +517,10 @@ Tcl_GetStringResult(interp)
*/
void
-Tcl_SetObjResult(interp, objPtr)
- Tcl_Interp *interp; /* Interpreter with which to associate the
+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
+ 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;
@@ -526,7 +544,7 @@ Tcl_SetObjResult(interp, objPtr)
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
- (*iPtr->freeProc)(iPtr->result);
+ iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
@@ -556,8 +574,8 @@ Tcl_SetObjResult(interp, objPtr)
*/
Tcl_Obj *
-Tcl_GetObjResult(interp)
- Tcl_Interp *interp; /* Interpreter whose result to return. */
+Tcl_GetObjResult(
+ Tcl_Interp *interp) /* Interpreter whose result to return. */
{
register Interp *iPtr = (Interp *) interp;
Tcl_Obj *objResultPtr;
@@ -568,7 +586,7 @@ Tcl_GetObjResult(interp)
* result, then reset the string result.
*/
- if (*(iPtr->result) != 0) {
+ if (iPtr->result[0] != 0) {
ResetObjResult(iPtr);
objResultPtr = iPtr->objResultPtr;
@@ -579,12 +597,12 @@ Tcl_GetObjResult(interp)
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;
+ iPtr->result[0] = 0;
}
return iPtr->objResultPtr;
}
@@ -610,10 +628,10 @@ Tcl_GetObjResult(interp)
*/
void
-Tcl_AppendResultVA(interp, argList)
- Tcl_Interp *interp; /* Interpreter with which to associate the
+Tcl_AppendResultVA(
+ 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);
@@ -631,14 +649,14 @@ Tcl_AppendResultVA(interp, argList)
* calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion]
*/
-#ifdef USE_DIRECT_INTERP_RESULT_ACCESS
+#ifdef USE_INTERP_RESULT
/*
* 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 */
+#endif /* USE_INTERP_RESULT */
}
/*
@@ -663,12 +681,12 @@ Tcl_AppendResultVA(interp, argList)
*/
void
-Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
+Tcl_AppendResult(
+ Tcl_Interp *interp, ...)
{
- Tcl_Interp *interp;
va_list argList;
- interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
+ va_start(argList, interp);
Tcl_AppendResultVA(interp, argList);
va_end(argList);
}
@@ -697,10 +715,10 @@ Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
*/
void
-Tcl_AppendElement(interp, element)
- Tcl_Interp *interp; /* Interpreter whose result is to be
+Tcl_AppendElement(
+ Tcl_Interp *interp, /* Interpreter whose result is to be
* extended. */
- CONST char *element; /* String to convert to list element and add
+ const char *element) /* String to convert to list element and add
* to result. */
{
Interp *iPtr = (Interp *) interp;
@@ -769,9 +787,9 @@ Tcl_AppendElement(interp, element)
*/
static void
-SetupAppendBuffer(iPtr, newSpace)
- Interp *iPtr; /* Interpreter whose result is being set up. */
- int newSpace; /* Make sure that at least this many bytes of
+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;
@@ -814,7 +832,7 @@ SetupAppendBuffer(iPtr, newSpace)
} else {
totalSpace *= 2;
}
- new = (char *) ckalloc((unsigned) totalSpace);
+ new = ckalloc(totalSpace);
strcpy(new, iPtr->result);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
@@ -852,8 +870,8 @@ SetupAppendBuffer(iPtr, newSpace)
*/
void
-Tcl_FreeResult(interp)
- register Tcl_Interp *interp; /* Interpreter for which to free result. */
+Tcl_FreeResult(
+ register Tcl_Interp *interp)/* Interpreter for which to free result. */
{
register Interp *iPtr = (Interp *) interp;
@@ -861,7 +879,7 @@ Tcl_FreeResult(interp)
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
- (*iPtr->freeProc)(iPtr->result);
+ iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
@@ -882,15 +900,15 @@ Tcl_FreeResult(interp)
* 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.
+ * initialized state, freeing up any memory that may have been allocated.
+ * It also clears any error information for the interpreter.
*
*----------------------------------------------------------------------
*/
void
-Tcl_ResetResult(interp)
- register Tcl_Interp *interp; /* Interpreter for which to clear result. */
+Tcl_ResetResult(
+ register Tcl_Interp *interp)/* Interpreter for which to clear result. */
{
register Interp *iPtr = (Interp *) interp;
@@ -899,7 +917,7 @@ Tcl_ResetResult(interp)
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
- (*iPtr->freeProc)(iPtr->result);
+ iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
@@ -907,25 +925,30 @@ Tcl_ResetResult(interp)
iPtr->resultSpace[0] = 0;
if (iPtr->errorCode) {
/* Legacy support */
- Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
- iPtr->errorCode, TCL_GLOBAL_ONLY);
+ 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 */
- Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
- iPtr->errorInfo, TCL_GLOBAL_ONLY);
+ 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;
+ iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY);
}
/*
@@ -947,8 +970,8 @@ Tcl_ResetResult(interp)
*/
static void
-ResetObjResult(iPtr)
- register Interp *iPtr; /* Points to the interpreter whose result
+ResetObjResult(
+ register Interp *iPtr) /* Points to the interpreter whose result
* object should be reset. */
{
register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
@@ -959,14 +982,14 @@ ResetObjResult(iPtr)
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
- if ((objResultPtr->bytes != NULL)
- && (objResultPtr->bytes != tclEmptyStringRep)) {
- ckfree((char *) objResultPtr->bytes);
+ if (objResultPtr->bytes != tclEmptyStringRep) {
+ if (objResultPtr->bytes) {
+ ckfree(objResultPtr->bytes);
+ }
+ objResultPtr->bytes = tclEmptyStringRep;
+ objResultPtr->length = 0;
}
- objResultPtr->bytes = tclEmptyStringRep;
- objResultPtr->length = 0;
TclFreeIntRep(objResultPtr);
- objResultPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
@@ -990,9 +1013,9 @@ ResetObjResult(iPtr)
*/
void
-Tcl_SetErrorCodeVA(interp, argList)
- Tcl_Interp *interp; /* Interpreter in which to set errorCode */
- va_list argList; /* Variable argument list. */
+Tcl_SetErrorCodeVA(
+ Tcl_Interp *interp, /* Interpreter in which to set errorCode */
+ va_list argList) /* Variable argument list. */
{
Tcl_Obj *errorObj = Tcl_NewObj();
@@ -1003,6 +1026,7 @@ Tcl_SetErrorCodeVA(interp, argList)
while (1) {
char *elem = va_arg(argList, char *);
+
if (elem == NULL) {
break;
}
@@ -1030,11 +1054,10 @@ Tcl_SetErrorCodeVA(interp, argList)
*----------------------------------------------------------------------
*/
- /* VARARGS2 */
void
-Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
+Tcl_SetErrorCode(
+ Tcl_Interp *interp, ...)
{
- Tcl_Interp *interp;
va_list argList;
/*
@@ -1042,7 +1065,7 @@ Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
* errorCode field as list elements.
*/
- interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
+ va_start(argList, interp);
Tcl_SetErrorCodeVA(interp, argList);
va_end(argList);
}
@@ -1066,9 +1089,9 @@ Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
*/
void
-Tcl_SetObjErrorCode(interp, errorObjPtr)
- Tcl_Interp *interp;
- Tcl_Obj *errorObjPtr;
+Tcl_SetObjErrorCode(
+ Tcl_Interp *interp,
+ Tcl_Obj *errorObjPtr)
{
Interp *iPtr = (Interp *) interp;
@@ -1082,6 +1105,43 @@ Tcl_SetObjErrorCode(interp, errorObjPtr)
/*
*----------------------------------------------------------------------
*
+ * Tcl_GetErrorLine --
+ *
+ * Returns the line number associated with the current error.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_GetErrorLine
+int
+Tcl_GetErrorLine(
+ Tcl_Interp *interp)
+{
+ return ((Interp *) interp)->errorLine;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetErrorLine --
+ *
+ * Sets the line number associated with the current error.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_SetErrorLine
+void
+Tcl_SetErrorLine(
+ Tcl_Interp *interp,
+ int value)
+{
+ ((Interp *) interp)->errorLine = value;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* GetKeys --
*
* Returns a Tcl_Obj * array of the standard keys used in the return
@@ -1094,14 +1154,14 @@ Tcl_SetObjErrorCode(interp, errorObjPtr)
* 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.
+ * First time called in a thread, creates the keys (allocating memory)
+ * and arranges for their cleanup at thread exit.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj **
-GetKeys()
+GetKeys(void)
{
static Tcl_ThreadDataKey returnKeysKey;
Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey,
@@ -1114,12 +1174,13 @@ GetKeys()
int i;
- keys[KEY_CODE] = Tcl_NewStringObj("-code", -1);
- keys[KEY_ERRORCODE] = Tcl_NewStringObj("-errorcode", -1);
- keys[KEY_ERRORINFO] = Tcl_NewStringObj("-errorinfo", -1);
- keys[KEY_ERRORLINE] = Tcl_NewStringObj("-errorline", -1);
- keys[KEY_LEVEL] = Tcl_NewStringObj("-level", -1);
- keys[KEY_OPTIONS] = Tcl_NewStringObj("-options", -1);
+ 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]);
@@ -1129,7 +1190,7 @@ GetKeys()
* ... and arrange for their clenaup.
*/
- Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys);
+ Tcl_CreateThreadExitHandler(ReleaseKeys, keys);
}
return keys;
}
@@ -1146,20 +1207,21 @@ GetKeys()
* None.
*
* Side effects:
- * Frees memory.
+ * Frees memory.
*
*----------------------------------------------------------------------
*/
-void
-ReleaseKeys(clientData)
- ClientData clientData;
+static void
+ReleaseKeys(
+ ClientData clientData)
{
- Tcl_Obj **keys = (Tcl_Obj **)clientData;
+ Tcl_Obj **keys = clientData;
int i;
for (i = KEY_CODE; i < KEY_LAST; i++) {
Tcl_DecrRefCount(keys[i]);
+ keys[i] = NULL;
}
}
@@ -1178,17 +1240,17 @@ ReleaseKeys(clientData)
* Returns the return code the [return] command should return.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
int
-TclProcessReturn(interp, code, level, returnOpts)
- Tcl_Interp *interp;
- int code;
- int level;
- Tcl_Obj *returnOpts;
+TclProcessReturn(
+ Tcl_Interp *interp,
+ int code,
+ int level,
+ Tcl_Obj *returnOpts)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *valuePtr;
@@ -1211,27 +1273,64 @@ TclProcessReturn(interp, code, level, returnOpts)
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
- Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr);
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
+ &valuePtr);
if (valuePtr != NULL) {
int infoLen;
- (void) Tcl_GetStringFromObj(valuePtr, &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);
+ 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);
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE],
+ &valuePtr);
if (valuePtr != NULL) {
- Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
+ TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
}
}
if (level != 0) {
@@ -1239,6 +1338,9 @@ TclProcessReturn(interp, code, level, returnOpts)
iPtr->returnCode = code;
return TCL_RETURN;
}
+ if (code == TCL_ERROR) {
+ iPtr->flags |= ERR_LEGACY_COPY;
+ }
return code;
}
@@ -1250,30 +1352,30 @@ TclProcessReturn(interp, code, level, returnOpts)
* 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_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.
+ * None.
*
*----------------------------------------------------------------------
*/
int
-TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
- Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a (Tcl_Obj
+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 */
+ * 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 code = TCL_OK;
int level = 1;
Tcl_Obj *valuePtr;
Tcl_Obj *returnOpts = Tcl_NewObj();
@@ -1281,12 +1383,12 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
for (; objc > 1; objv += 2, objc -= 2) {
int optLen;
- CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen);
+ const char *opt = TclGetStringFromObj(objv[0], &optLen);
int compareLen;
- CONST char *compare =
- Tcl_GetStringFromObj(keys[KEY_OPTIONS], &compareLen);
+ const char *compare =
+ TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen);
- if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) {
+ if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) {
Tcl_DictSearch search;
int done = 0;
Tcl_Obj *keyPtr;
@@ -1299,10 +1401,11 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
* Value is not a legal dictionary.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad ", compare,
- " value: expected dictionary but got \"",
- TclGetString(objv[1]), "\"", (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad %s value: expected dictionary but got \"%s\"",
+ compare, TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS",
+ NULL);
goto error;
}
@@ -1328,20 +1431,9 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
- if ((valuePtr != NULL)
- && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
- static CONST char *returnCodes[] = {
- "ok", "error", "return", "break", "continue", NULL
- };
-
- if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
- NULL, TCL_EXACT, &code)) {
- /* Value is not a legal return code */
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad completion code \"",
- TclGetString(valuePtr),
- "\": must be ok, error, return, break, ",
- "continue, or an integer", (char *) NULL);
+ if (valuePtr != NULL) {
+ if (TclGetCompletionCodeFromObj(interp, valuePtr,
+ &code) == TCL_ERROR) {
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
@@ -1353,22 +1445,78 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr);
if (valuePtr != NULL) {
- if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level))
+ 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), "\"", (char *) NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad -level value: expected non-negative integer but got"
+ " \"%s\"", TclGetString(valuePtr)));
+ 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_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad -errorcode value: expected a list but got \"%s\"",
+ TclGetString(valuePtr)));
+ 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_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad -errorstack value: expected a list but got \"%s\"",
+ TclGetString(valuePtr)));
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
+ NULL);
+ goto error;
+ }
+ if (length % 2) {
+ /*
+ * Errorstack must always be an even-sized list
+ */
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "forbidden odd-sized list for -errorstack: \"%s\"",
+ TclGetString(valuePtr)));
+ Tcl_SetErrorCode(interp, "TCL", "RESULT",
+ "ODDSIZEDLIST_ERRORSTACK", NULL);
+ goto error;
+ }
+ }
+
+ /*
* Convert [return -code return -level X] to [return -code ok -level X+1]
*/
@@ -1417,9 +1565,9 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
*/
Tcl_Obj *
-Tcl_GetReturnOptions(interp, result)
- Tcl_Interp *interp;
- int result;
+Tcl_GetReturnOptions(
+ Tcl_Interp *interp,
+ int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *options;
@@ -1444,14 +1592,14 @@ Tcl_GetReturnOptions(interp, result)
}
if (result == TCL_ERROR) {
- /*
- * When result was an error, fill in any missing values for
- * -errorinfo, -errorcode, and -errorline
- */
-
- Tcl_AddObjErrorInfo(interp, "", -1);
- Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
+ Tcl_AddErrorInfo(interp, "");
+ 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));
}
@@ -1461,6 +1609,31 @@ Tcl_GetReturnOptions(interp, result)
/*
*-------------------------------------------------------------------------
*
+ * 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();
+
+ Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]);
+ return options;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
* Tcl_SetReturnOptions --
*
* Accepts an interp and a dictionary of return options, and sets the
@@ -1479,18 +1652,19 @@ Tcl_GetReturnOptions(interp, result)
*/
int
-Tcl_SetReturnOptions(interp, options)
- Tcl_Interp *interp;
- Tcl_Obj *options;
+Tcl_SetReturnOptions(
+ Tcl_Interp *interp,
+ Tcl_Obj *options)
{
int objc, level, code;
Tcl_Obj **objv, *mergedOpts;
- if (TCL_ERROR == Tcl_ListObjGetElements(interp, options, &objc, &objv)
+ Tcl_IncrRefCount(options);
+ if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
|| (objc % 2)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "expected dict but got \"",
- Tcl_GetString(options), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected dict but got \"%s\"", TclGetString(options)));
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL);
code = TCL_ERROR;
} else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
&mergedOpts, &code, &level)) {
@@ -1506,7 +1680,7 @@ Tcl_SetReturnOptions(interp, options)
/*
*-------------------------------------------------------------------------
*
- * TclTransferResult --
+ * 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
@@ -1532,27 +1706,40 @@ Tcl_SetReturnOptions(interp, options)
*/
void
-TclTransferResult(sourceInterp, result, targetInterp)
- Tcl_Interp *sourceInterp; /* Interp whose result and error information
+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
* is reset. */
- int result; /* TCL_OK if just the result should be copied,
+ 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
+ Tcl_Interp *targetInterp) /* Interp where result and error information
* should be stored. If source and target are
* the same, nothing is done. */
{
- Interp *iPtr = (Interp *) targetInterp;
+ Interp *tiPtr = (Interp *) targetInterp;
+ Interp *siPtr = (Interp *) sourceInterp;
if (sourceInterp == targetInterp) {
return;
}
- Tcl_SetReturnOptions(targetInterp,
- Tcl_GetReturnOptions(sourceInterp, result));
- iPtr->flags &= ~(ERR_ALREADY_LOGGED);
+ 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);
}
@@ -1562,5 +1749,7 @@ TclTransferResult(sourceInterp, result, targetInterp)
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
generated by cgit v0.12 at 2025-10-21 21:18:52 (GMT)