summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclBasic.c18
-rw-r--r--generic/tclExecute.c10
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclProc.c13
5 files changed, 41 insertions, 16 deletions
diff --git a/ChangeLog b/ChangeLog
index 10f21e5..566cc0f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,17 @@
2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
+ * generic/tclBasic.c (Tcl_AddObjErrorInfo):
+ * generic/tclExecute.c (TclUpdateReturnInfo):
+ * generic/tclInt.h:
+ * generic/tclProc.c:
+ Added two Tcl_Obj to the ExecEnv structure to hold the fully
+ qualified names "::errorInfo" and "::errorCode" to cache the
+ addresses of the corresponding variables. The two most frequent
+ setters of these variables now profit from the new variable name
+ caching.
+
+2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
+
* generic/tclVar.c: refactorisation to reuse already looked-up Var
pointers; definition of three new Tcl_Obj types to cache variable
name parsing and lookup for later reuse; modification of internal
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 578b26f..b60a6c3 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.62 2002/06/20 16:41:30 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.63 2002/07/16 01:12:50 msofer Exp $
*/
#include "tclInt.h"
@@ -5084,11 +5084,11 @@ Tcl_AddObjErrorInfo(interp, message, length)
iPtr->flags |= ERR_IN_PROGRESS;
if (iPtr->result[0] == 0) {
- (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr,
- TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
+ iPtr->objResultPtr, TCL_GLOBAL_ONLY);
} else { /* use the string result */
- Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
- TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
+ Tcl_NewStringObj(interp->result, -1), TCL_GLOBAL_ONLY);
}
/*
@@ -5097,8 +5097,8 @@ Tcl_AddObjErrorInfo(interp, message, length)
*/
if (!(iPtr->flags & ERROR_CODE_SET)) {
- (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
- TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
+ Tcl_NewStringObj("NONE", -1), TCL_GLOBAL_ONLY);
}
}
@@ -5109,8 +5109,8 @@ Tcl_AddObjErrorInfo(interp, message, length)
if (length != 0) {
messagePtr = Tcl_NewStringObj(message, length);
Tcl_IncrRefCount(messagePtr);
- Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr,
- (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
+ Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
+ messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
}
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 1375b20..024509e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.76 2002/07/10 08:25:59 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.77 2002/07/16 01:12:50 msofer Exp $
*/
#include "tclInt.h"
@@ -514,6 +514,12 @@ TclCreateExecEnv(interp)
eePtr->stackTop = -1;
eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
+ eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1);
+ Tcl_IncrRefCount(eePtr->errorInfo);
+
+ eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1);
+ Tcl_IncrRefCount(eePtr->errorCode);
+
Tcl_MutexLock(&execMutex);
if (!execInitialized) {
TclInitAuxDataTypeTable();
@@ -548,6 +554,8 @@ TclDeleteExecEnv(eePtr)
ExecEnv *eePtr; /* Execution environment to free. */
{
Tcl_EventuallyFree((ClientData)eePtr->stackPtr, TCL_DYNAMIC);
+ TclDecrRefCount(eePtr->errorInfo);
+ TclDecrRefCount(eePtr->errorCode);
ckfree((char *) eePtr);
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 5604129..6a891e0 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.98 2002/07/15 22:18:04 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.99 2002/07/16 01:12:50 msofer Exp $
*/
#ifndef _TCLINT
@@ -910,6 +910,8 @@ typedef struct ExecEnv {
int stackTop; /* Index of current top of stack; -1 when
* the stack is empty. */
int stackEnd; /* Index of last usable item in stack. */
+ Tcl_Obj *errorInfo;
+ Tcl_Obj *errorCode;
} ExecEnv;
/*
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 91d6714..4c656b4 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.38 2002/07/11 12:39:16 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.39 2002/07/16 01:12:50 msofer Exp $
*/
#include "tclInt.h"
@@ -1421,17 +1421,20 @@ TclUpdateReturnInfo(iPtr)
* exception is being processed. */
{
int code;
+ char *errorCode;
code = iPtr->returnCode;
iPtr->returnCode = TCL_OK;
if (code == TCL_ERROR) {
- Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
- (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
+ errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
+ Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
+ NULL, Tcl_NewStringObj(errorCode, -1),
TCL_GLOBAL_ONLY);
iPtr->flags |= ERROR_CODE_SET;
if (iPtr->errorInfo != NULL) {
- Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,
- iPtr->errorInfo, TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
+ NULL, Tcl_NewStringObj(iPtr->errorInfo, -1),
+ TCL_GLOBAL_ONLY);
iPtr->flags |= ERR_IN_PROGRESS;
}
}