summaryrefslogtreecommitdiffstats
path: root/generic/tclResult.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclResult.c')
-rw-r--r--generic/tclResult.c494
1 files changed, 166 insertions, 328 deletions
diff --git a/generic/tclResult.c b/generic/tclResult.c
index b35aee0..7b58d44 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -3,7 +3,7 @@
*
* This file contains code to manage the interpreter result.
*
- * Copyright © 1997 Sun Microsystems, Inc.
+ * 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.
@@ -17,7 +17,7 @@
enum returnKeys {
KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE,
- KEY_LEVEL, KEY_OPTIONS, KEY_ERRORSTACK, KEY_LAST
+ KEY_LEVEL, KEY_OPTIONS, KEY_LAST
};
/*
@@ -27,9 +27,7 @@ enum returnKeys {
static Tcl_Obj ** GetKeys(void);
static void ReleaseKeys(ClientData clientData);
static void ResetObjResult(Interp *iPtr);
-#ifndef TCL_NO_DEPRECATED
static void SetupAppendBuffer(Interp *iPtr, int newSpace);
-#endif /* !TCL_NO_DEPRECATED */
/*
* This structure is used to take a snapshot of the interpreter state in
@@ -37,7 +35,7 @@ static void SetupAppendBuffer(Interp *iPtr, int newSpace);
* then back up to the result or the error that was previously in progress.
*/
-typedef struct {
+typedef struct InterpState {
int status; /* return code status */
int flags; /* Each remaining field saves the */
int returnLevel; /* corresponding field of the Interp */
@@ -46,8 +44,6 @@ typedef struct {
Tcl_Obj *errorCode;
Tcl_Obj *returnOpts;
Tcl_Obj *objResult;
- Tcl_Obj *errorStack;
- int resetErrorStack;
} InterpState;
/*
@@ -76,7 +72,7 @@ Tcl_SaveInterpState(
Tcl_Interp *interp, /* Interpreter's state to be saved */
int status) /* status code for current operation */
{
- Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *)interp;
InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));
statePtr->status = status;
@@ -84,8 +80,6 @@ Tcl_SaveInterpState(
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);
}
@@ -97,9 +91,6 @@ Tcl_SaveInterpState(
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;
@@ -128,8 +119,8 @@ 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;
@@ -137,7 +128,6 @@ Tcl_RestoreInterpState(
iPtr->returnLevel = statePtr->returnLevel;
iPtr->returnCode = statePtr->returnCode;
- iPtr->resetErrorStack = statePtr->resetErrorStack;
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
}
@@ -152,13 +142,6 @@ Tcl_RestoreInterpState(
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);
}
@@ -192,7 +175,7 @@ void
Tcl_DiscardInterpState(
Tcl_InterpState state) /* saved interpreter state */
{
- InterpState *statePtr = (InterpState *) state;
+ InterpState *statePtr = (InterpState *)state;
if (statePtr->errorInfo) {
Tcl_DecrRefCount(statePtr->errorInfo);
@@ -203,11 +186,8 @@ Tcl_DiscardInterpState(
if (statePtr->returnOpts) {
Tcl_DecrRefCount(statePtr->returnOpts);
}
- if (statePtr->errorStack) {
- Tcl_DecrRefCount(statePtr->errorStack);
- }
Tcl_DecrRefCount(statePtr->objResult);
- ckfree(statePtr);
+ ckfree((char *) statePtr);
}
/*
@@ -232,8 +212,6 @@ Tcl_DiscardInterpState(
*----------------------------------------------------------------------
*/
-#ifndef TCL_NO_DEPRECATED
-#undef Tcl_SaveResult
void
Tcl_SaveResult(
Tcl_Interp *interp, /* Interpreter to save. */
@@ -248,7 +226,7 @@ Tcl_SaveResult(
*/
statePtr->objResultPtr = iPtr->objResultPtr;
- TclNewObj(iPtr->objResultPtr);
+ iPtr->objResultPtr = Tcl_NewObj();
Tcl_IncrRefCount(iPtr->objResultPtr);
/*
@@ -308,7 +286,6 @@ Tcl_SaveResult(
*----------------------------------------------------------------------
*/
-#undef Tcl_RestoreResult
void
Tcl_RestoreResult(
Tcl_Interp *interp, /* Interpreter being restored. */
@@ -336,7 +313,7 @@ Tcl_RestoreResult(
*/
if (iPtr->appendResult != NULL) {
- ckfree(iPtr->appendResult);
+ ckfree((char *) iPtr->appendResult);
}
iPtr->appendResult = statePtr->appendResult;
@@ -377,7 +354,6 @@ Tcl_RestoreResult(
*----------------------------------------------------------------------
*/
-#undef Tcl_DiscardResult
void
Tcl_DiscardResult(
Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */
@@ -386,10 +362,12 @@ Tcl_DiscardResult(
if (statePtr->result == statePtr->appendResult) {
ckfree(statePtr->appendResult);
- } else if (statePtr->freeProc == TCL_DYNAMIC) {
- ckfree(statePtr->result);
} else if (statePtr->freeProc) {
- statePtr->freeProc(statePtr->result);
+ if (statePtr->freeProc == TCL_DYNAMIC) {
+ ckfree(statePtr->result);
+ } else {
+ (*statePtr->freeProc)(statePtr->result);
+ }
}
}
@@ -414,14 +392,15 @@ void
Tcl_SetResult(
Tcl_Interp *interp, /* Interpreter with which to associate the
* return value. */
- 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_STATIC, TCL_VOLATILE, or the address of
* a Tcl_FreeProc such as free. */
{
Interp *iPtr = (Interp *) interp;
- Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
+ int length;
+ register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
char *oldResult = iPtr->result;
if (result == NULL) {
@@ -429,18 +408,17 @@ Tcl_SetResult(
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
} else if (freeProc == TCL_VOLATILE) {
- int length = strlen(result);
-
+ length = strlen(result);
if (length > TCL_RESULT_SIZE) {
- iPtr->result = (char *)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, length+1);
+ strcpy(iPtr->result, result);
} else {
- iPtr->result = (char *) result;
+ iPtr->result = result;
iPtr->freeProc = freeProc;
}
@@ -454,7 +432,7 @@ Tcl_SetResult(
if (oldFreeProc == TCL_DYNAMIC) {
ckfree(oldResult);
} else {
- oldFreeProc(oldResult);
+ (*oldFreeProc)(oldResult);
}
}
@@ -464,7 +442,6 @@ Tcl_SetResult(
ResetObjResult(iPtr);
}
-#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -483,26 +460,20 @@ Tcl_SetResult(
*----------------------------------------------------------------------
*/
-#undef Tcl_GetStringResult
-const char *
+CONST char *
Tcl_GetStringResult(
- Tcl_Interp *interp)/* Interpreter whose result to return. */
+ register Tcl_Interp *interp)/* Interpreter whose result to return. */
{
-#ifndef TCL_NO_DEPRECATED
- Interp *iPtr = (Interp *) interp;
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
- if (*(iPtr->result) == 0) {
+ if (*(interp->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
- return iPtr->result;
-#else
- return TclGetString(Tcl_GetObjResult(interp));
-#endif
+ return interp->result;
}
/*
@@ -528,11 +499,11 @@ void
Tcl_SetObjResult(
Tcl_Interp *interp, /* Interpreter with which to associate the
* return object value. */
- 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. */
{
- Interp *iPtr = (Interp *) interp;
- Tcl_Obj *oldObjResult = iPtr->objResultPtr;
+ register Interp *iPtr = (Interp *) interp;
+ register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
iPtr->objResultPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
@@ -544,7 +515,6 @@ Tcl_SetObjResult(
TclDecrRefCount(oldObjResult);
-#ifndef TCL_NO_DEPRECATED
/*
* Reset the string result since we just set the result object.
*/
@@ -553,13 +523,12 @@ Tcl_SetObjResult(
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;
-#endif
}
/*
@@ -587,8 +556,7 @@ Tcl_Obj *
Tcl_GetObjResult(
Tcl_Interp *interp) /* Interpreter whose result to return. */
{
- Interp *iPtr = (Interp *) interp;
-#ifndef TCL_NO_DEPRECATED
+ register Interp *iPtr = (Interp *) interp;
Tcl_Obj *objResultPtr;
int length;
@@ -597,7 +565,7 @@ Tcl_GetObjResult(
* result, then reset the string result.
*/
- if (iPtr->result[0] != 0) {
+ if (*(iPtr->result) != 0) {
ResetObjResult(iPtr);
objResultPtr = iPtr->objResultPtr;
@@ -608,14 +576,13 @@ Tcl_GetObjResult(
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->result[0] = 0;
+ iPtr->resultSpace[0] = 0;
}
-#endif /* !TCL_NO_DEPRECATED */
return iPtr->objResultPtr;
}
@@ -652,6 +619,23 @@ Tcl_AppendResultVA(
}
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 */
}
/*
@@ -713,29 +697,13 @@ void
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;
-#ifdef TCL_NO_DEPRECATED
- Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1);
- Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
- const char *bytes;
-
- if (Tcl_IsShared(iPtr->objResultPtr)) {
- Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
- }
- bytes = TclGetString(iPtr->objResultPtr);
- if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) {
- Tcl_AppendToObj(iPtr->objResultPtr, " ", 1);
- }
- Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr);
- Tcl_DecrRefCount(listPtr);
-#else
char *dst;
int size;
int flags;
- int quoteHash = 1;
/*
* If the string result is empty, move the object result to the string
@@ -772,19 +740,10 @@ Tcl_AppendElement(
* then this element will not lead a list, and need not have it's
* leading '#' quoted.
*/
- quoteHash = 0;
- } else {
- while ((--dst >= iPtr->appendResult) && TclIsSpaceProcM(*dst)) {
- }
- quoteHash = !TclNeedSpace(iPtr->appendResult, dst+1);
- }
- dst = iPtr->appendResult + iPtr->appendUsed;
- if (!quoteHash) {
+
flags |= TCL_DONT_QUOTE_HASH;
}
-
iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags);
-#endif /* !TCL_NO_DEPRECATED */
}
/*
@@ -806,7 +765,6 @@ Tcl_AppendElement(
*----------------------------------------------------------------------
*/
-#ifndef TCL_NO_DEPRECATED
static void
SetupAppendBuffer(
Interp *iPtr, /* Interpreter whose result is being set up. */
@@ -846,19 +804,19 @@ SetupAppendBuffer(
totalSpace = newSpace + iPtr->appendUsed;
if (totalSpace >= iPtr->appendAvl) {
- char *newSpacePtr;
+ char *new;
if (totalSpace < 100) {
totalSpace = 200;
} else {
totalSpace *= 2;
}
- newSpacePtr = (char *)ckalloc(totalSpace);
- strcpy(newSpacePtr, iPtr->result);
+ new = (char *) ckalloc((unsigned) totalSpace);
+ strcpy(new, iPtr->result);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
}
- iPtr->appendResult = newSpacePtr;
+ iPtr->appendResult = new;
iPtr->appendAvl = totalSpace;
} else if (iPtr->result != iPtr->appendResult) {
strcpy(iPtr->appendResult, iPtr->result);
@@ -892,23 +850,22 @@ SetupAppendBuffer(
void
Tcl_FreeResult(
- Tcl_Interp *interp)/* Interpreter for which to free result. */
+ register Tcl_Interp *interp)/* Interpreter for which to free result. */
{
- Interp *iPtr = (Interp *) interp;
+ 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);
}
-#endif /* !TCL_NO_DEPRECATED */
-
+
/*
*----------------------------------------------------------------------
*
@@ -930,23 +887,21 @@ Tcl_FreeResult(
void
Tcl_ResetResult(
- Tcl_Interp *interp)/* Interpreter for which to clear result. */
+ register Tcl_Interp *interp)/* Interpreter for which to clear result. */
{
- Interp *iPtr = (Interp *) interp;
+ register Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
-#ifndef TCL_NO_DEPRECATED
if (iPtr->freeProc != NULL) {
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;
-#endif /* !TCL_NO_DEPRECATED */
if (iPtr->errorCode) {
/* Legacy support */
if (iPtr->flags & ERR_LEGACY_COPY) {
@@ -965,7 +920,6 @@ Tcl_ResetResult(
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
- iPtr->resetErrorStack = 1;
iPtr->returnLevel = 1;
iPtr->returnCode = TCL_OK;
if (iPtr->returnOpts) {
@@ -995,10 +949,10 @@ Tcl_ResetResult(
static void
ResetObjResult(
- Interp *iPtr) /* Points to the interpreter whose result
+ register Interp *iPtr) /* Points to the interpreter whose result
* object should be reset. */
{
- Tcl_Obj *objResultPtr = iPtr->objResultPtr;
+ register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
if (Tcl_IsShared(objResultPtr)) {
TclDecrRefCount(objResultPtr);
@@ -1006,14 +960,15 @@ ResetObjResult(
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
- if (objResultPtr->bytes != &tclEmptyString) {
+ if (objResultPtr->bytes != tclEmptyStringRep) {
if (objResultPtr->bytes) {
- ckfree(objResultPtr->bytes);
+ ckfree((char *) objResultPtr->bytes);
}
- objResultPtr->bytes = &tclEmptyString;
+ objResultPtr->bytes = tclEmptyStringRep;
objResultPtr->length = 0;
}
- TclFreeInternalRep(objResultPtr);
+ TclFreeIntRep(objResultPtr);
+ objResultPtr->typePtr = NULL;
}
}
@@ -1041,17 +996,15 @@ Tcl_SetErrorCodeVA(
Tcl_Interp *interp, /* Interpreter in which to set errorCode */
va_list argList) /* Variable argument list. */
{
- Tcl_Obj *errorObj;
+ Tcl_Obj *errorObj = Tcl_NewObj();
/*
* Scan through the arguments one at a time, appending them to the
* errorCode field as list elements.
*/
- TclNewObj(errorObj);
while (1) {
char *elem = va_arg(argList, char *);
-
if (elem == NULL) {
break;
}
@@ -1130,43 +1083,6 @@ Tcl_SetObjErrorCode(
/*
*----------------------------------------------------------------------
*
- * 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
@@ -1179,8 +1095,8 @@ Tcl_SetErrorLine(
* 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.
*
*----------------------------------------------------------------------
*/
@@ -1189,8 +1105,8 @@ static Tcl_Obj **
GetKeys(void)
{
static Tcl_ThreadDataKey returnKeysKey;
- Tcl_Obj **keys = (Tcl_Obj **)Tcl_GetThreadData(&returnKeysKey,
- KEY_LAST * sizeof(Tcl_Obj *));
+ Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey,
+ (int) (KEY_LAST * sizeof(Tcl_Obj *)));
if (keys[0] == NULL) {
/*
@@ -1203,7 +1119,6 @@ GetKeys(void)
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");
@@ -1215,7 +1130,7 @@ GetKeys(void)
* ... and arrange for their clenaup.
*/
- Tcl_CreateThreadExitHandler(ReleaseKeys, keys);
+ Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys);
}
return keys;
}
@@ -1232,7 +1147,7 @@ GetKeys(void)
* None.
*
* Side effects:
- * Frees memory.
+ * Frees memory.
*
*----------------------------------------------------------------------
*/
@@ -1265,7 +1180,7 @@ ReleaseKeys(
* Returns the return code the [return] command should return.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -1298,60 +1213,25 @@ TclProcessReturn(
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) {
- (void) TclGetString(valuePtr);
- if (valuePtr->length) {
+ 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 (TclListObjGetElements(interp, valuePtr, &valueObjc,
- &valueObjv) == TCL_ERROR) {
- return TCL_ERROR;
- }
- iPtr->resetErrorStack = 0;
- TclListObjLength(interp, iPtr->errorStack, &len);
-
- /*
- * Reset while keeping the list internalrep as much as possible.
- */
-
- Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
- valueObjv);
- }
- Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE],
- &valuePtr);
+ Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr);
if (valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
} else {
- Tcl_SetErrorCode(interp, "NONE", (void *)NULL);
+ 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) {
TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
}
@@ -1375,12 +1255,12 @@ TclProcessReturn(
* 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_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.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -1388,29 +1268,30 @@ TclProcessReturn(
int
TclMergeReturnOptions(
Tcl_Interp *interp, /* Current interpreter. */
- Tcl_Size objc, /* Number of arguments. */
- Tcl_Obj *const objv[], /* Argument objects. */
+ 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. */
+ * options dictionary should be written */
int *codePtr, /* If not NULL, points to space where the
- * -code value should be written. */
+ * -code value should be written */
int *levelPtr) /* If not NULL, points to space where the
- * -level value should be written. */
+ * -level value should be written */
{
- int code = TCL_OK;
+ int code=TCL_OK;
int level = 1;
Tcl_Obj *valuePtr;
- Tcl_Obj *returnOpts;
+ Tcl_Obj *returnOpts = Tcl_NewObj();
Tcl_Obj **keys = GetKeys();
- TclNewObj(returnOpts);
for (; objc > 1; objv += 2, objc -= 2) {
- const char *opt = TclGetString(objv[0]);
- const char *compare = TclGetString(keys[KEY_OPTIONS]);
+ int optLen;
+ CONST char *opt = TclGetStringFromObj(objv[0], &optLen);
+ int compareLen;
+ CONST char *compare =
+ TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen);
- if ((objv[0]->length == keys[KEY_OPTIONS]->length)
- && (memcmp(opt, compare, objv[0]->length) == 0)) {
+ if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) {
Tcl_DictSearch search;
int done = 0;
Tcl_Obj *keyPtr;
@@ -1423,11 +1304,10 @@ TclMergeReturnOptions(
* Value is not a legal dictionary.
*/
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad %s value: expected dictionary but got \"%s\"",
- compare, TclGetString(objv[1])));
- Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS",
- (void *)NULL);
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad ", compare,
+ " value: expected dictionary but got \"",
+ TclGetString(objv[1]), "\"", NULL);
goto error;
}
@@ -1453,11 +1333,27 @@ TclMergeReturnOptions(
*/
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
- if (valuePtr != NULL) {
- if (TclGetCompletionCodeFromObj(interp, valuePtr,
- &code) == TCL_ERROR) {
+ 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]);
}
@@ -1473,10 +1369,10 @@ TclMergeReturnOptions(
* Value is not a legal level.
*/
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad -level value: expected non-negative integer but got"
- " \"%s\"", TclGetString(valuePtr)));
- Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", (void *)NULL);
+ 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]);
@@ -1490,52 +1386,16 @@ TclMergeReturnOptions(
if (valuePtr != NULL) {
int length;
- if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &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",
- (void *)NULL);
- goto error;
- }
- }
-
- /*
- * Check for bogus -errorstack value.
- */
-
- Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr);
- if (valuePtr != NULL) {
- int length;
-
- if (TCL_ERROR == TclListObjLength(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",
- (void *)NULL);
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad -errorcode value: "
+ "expected a list but got \"",
+ TclGetString(valuePtr), "\"", 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", (void *)NULL);
- goto error;
- }
}
/*
@@ -1598,24 +1458,23 @@ Tcl_GetReturnOptions(
if (iPtr->returnOpts) {
options = Tcl_DuplicateObj(iPtr->returnOpts);
} else {
- TclNewObj(options);
+ options = Tcl_NewObj();
}
if (result == TCL_RETURN) {
Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
- Tcl_NewWideIntObj(iPtr->returnCode));
+ Tcl_NewIntObj(iPtr->returnCode));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
- Tcl_NewWideIntObj(iPtr->returnLevel));
+ Tcl_NewIntObj(iPtr->returnLevel));
} else {
Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
- Tcl_NewWideIntObj(result));
+ Tcl_NewIntObj(result));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
- Tcl_NewWideIntObj(0));
+ Tcl_NewIntObj(0));
}
if (result == TCL_ERROR) {
- Tcl_AddErrorInfo(interp, "");
- Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack);
+ Tcl_AddObjErrorInfo(interp, "", -1);
}
if (iPtr->errorCode) {
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
@@ -1623,7 +1482,7 @@ Tcl_GetReturnOptions(
if (iPtr->errorInfo) {
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
- Tcl_NewWideIntObj(iPtr->errorLine));
+ Tcl_NewIntObj(iPtr->errorLine));
}
return options;
}
@@ -1631,31 +1490,6 @@ Tcl_GetReturnOptions(
/*
*-------------------------------------------------------------------------
*
- * 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
@@ -1684,9 +1518,9 @@ Tcl_SetReturnOptions(
Tcl_IncrRefCount(options);
if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
|| (objc % 2)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "expected dict but got \"%s\"", TclGetString(options)));
- Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", (void *)NULL);
+ 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)) {
@@ -1702,16 +1536,24 @@ Tcl_SetReturnOptions(
/*
*-------------------------------------------------------------------------
*
- * Tcl_TransferResult --
+ * TclTransferResult --
*
- * Transfer the result (and error information) from one interp to another.
+ * 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 result of targetInterp is set to the result read from sourceInterp.
- * The return options dictionary of sourceInterp is transferred to
- * targetInterp as appropriate for the return code value code.
+ * 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.
@@ -1720,17 +1562,15 @@ Tcl_SetReturnOptions(
*/
void
-Tcl_TransferResult(
- Tcl_Interp *sourceInterp, /* Interp whose result and return options
+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 code, /* The return code value active in
- * sourceInterp. Controls how the return options
- * dictionary is retrieved from sourceInterp,
- * same as in Tcl_GetReturnOptions, to then be
- * transferred to targetInterp. */
- Tcl_Interp *targetInterp) /* Interp where result and return options
+ 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. */
{
@@ -1741,7 +1581,7 @@ Tcl_TransferResult(
return;
}
- if (code == TCL_OK && siPtr->returnOpts == NULL) {
+ if (result == TCL_OK && siPtr->returnOpts == NULL) {
/*
* Special optimization for the common case of normal command return
* code and no explicit return options.
@@ -1753,7 +1593,7 @@ Tcl_TransferResult(
}
} else {
Tcl_SetReturnOptions(targetInterp,
- Tcl_GetReturnOptions(sourceInterp, code));
+ Tcl_GetReturnOptions(sourceInterp, result));
tiPtr->flags &= ~(ERR_ALREADY_LOGGED);
}
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
@@ -1765,7 +1605,5 @@ Tcl_TransferResult(
* mode: c
* c-basic-offset: 4
* fill-column: 78
- * tab-width: 8
- * indent-tabs-mode: nil
* End:
*/
generated by cgit v0.12 at 2025-12-20 11:10:00 (GMT)