Attachment "errorcode.patch" to
ticket [1616470fff]
added by
dkf
2006-12-15 22:19:33.
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.3307
diff -u -r1.3307 ChangeLog
--- ChangeLog 14 Dec 2006 10:22:02 -0000 1.3307
+++ ChangeLog 15 Dec 2006 15:13:37 -0000
@@ -1,3 +1,20 @@
+2006-12-15 Donal K. Fellows <[email protected]>
+
+ * generic/tclDictObj.c (TclTraceDictPath):
+ * generic/tclEncoding.c (OpenEncodingFileChannel):
+ * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct):
+ * generic/tclInterp.c (Tcl_InterpObjCmd, AliasDelete, Tcl_GetAlias)
+ (Tcl_GetAliasObj, GetInterp):
+ * generic/tclIO.c (Tcl_GetChannel):
+ * generic/tclNamesp.c (Tcl_FindNamespace, Tcl_FindCommand)
+ (Tcl_FindNamespaceVar, NamespaceChildrenCmd, NamespaceDeleteCmd)
+ (NamespaceInscopeCmd, NamespaceParentCmd, NamespacePathCmd)
+ (NsEnsembleImplementationCmd):
+ * generic/tclPkg.c (Tcl_PkgPresentEx):
+ * generic/tclVar.c (TclLookupArrayElement, ParseSearchId):
+ Start to return more useful Error codes on lookup failures, prompted
+ by complaints on comp.lang.tcl.
+
2006-12-14 Donal K. Fellows <[email protected]>
* doc/string.n: Fix example. [Bug 1615277]
Index: generic/tclDictObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDictObj.c,v
retrieving revision 1.46
diff -u -r1.46 tclDictObj.c
--- generic/tclDictObj.c 28 Nov 2006 22:20:28 -0000 1.46
+++ generic/tclDictObj.c 15 Dec 2006 15:13:39 -0000
@@ -624,6 +624,8 @@
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "key \"", TclGetString(keyv[i]),
"\" not known in dictionary", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "DICT",
+ TclGetString(keyv[i]), NULL);
}
return NULL;
}
Index: generic/tclEncoding.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclEncoding.c,v
retrieving revision 1.51
diff -u -r1.51 tclEncoding.c
--- generic/tclEncoding.c 13 Nov 2006 08:23:07 -0000 1.51
+++ generic/tclEncoding.c 15 Dec 2006 15:13:42 -0000
@@ -1492,6 +1492,7 @@
if ((NULL == chan) && (interp != NULL)) {
Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "ENCODING", name, NULL);
}
Tcl_DecrRefCount(fileNameObj);
Tcl_DecrRefCount(nameObj);
@@ -2088,9 +2089,9 @@
*
* UtfExtToUtfIntProc --
*
- * Convert from UTF-8 to UTF-8 while converting null-bytes from
- * the official representation (0x00) to Tcl's internal
- * representation (0xc0, 0x80). See UtfToUtfProc for details.
+ * Convert from UTF-8 to UTF-8 while converting null-bytes from the
+ * official representation (0x00) to Tcl's internal representation (0xc0,
+ * 0x80). See UtfToUtfProc for details.
*
* Results:
* Returns TCL_OK if conversion was successful.
Index: generic/tclIO.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIO.c,v
retrieving revision 1.112
diff -u -r1.112 tclIO.c
--- generic/tclIO.c 13 Nov 2006 17:51:34 -0000 1.112
+++ generic/tclIO.c 15 Dec 2006 15:13:49 -0000
@@ -1023,6 +1023,7 @@
if (hPtr == NULL) {
Tcl_AppendResult(interp, "can not find channel named \"", chanName,
"\"", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "CHANNEL", chanName, NULL);
return NULL;
}
@@ -6913,6 +6914,7 @@
if ((len > 2) && (optionName[1] == 'b') &&
(strncmp(optionName, "-blocking", len) == 0)) {
int newMode;
+
if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -6947,6 +6949,7 @@
} else if ((len > 7) && (optionName[1] == 'b') &&
(strncmp(optionName, "-buffersize", len) == 0)) {
int newBufferSize;
+
if (Tcl_GetInt(interp, newValue, &newBufferSize) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -7018,9 +7021,9 @@
}
/*
- * [SF Tcl Bug 930851] Reset EOF and BLOCKED flags. Changing the
- * character which signals eof can transform a current eof condition
- * into a 'go ahead'. Ditto for blocked.
+ * [Bug 930851] Reset EOF and BLOCKED flags. Changing the character
+ * which signals eof can transform a current eof condition into a 'go
+ * ahead'. Ditto for blocked.
*/
statePtr->flags &=
Index: generic/tclIndexObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIndexObj.c,v
retrieving revision 1.31
diff -u -r1.31 tclIndexObj.c
--- generic/tclIndexObj.c 6 Apr 2006 18:57:58 -0000 1.31
+++ generic/tclIndexObj.c 15 Dec 2006 15:13:50 -0000
@@ -275,6 +275,7 @@
Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
}
}
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "INDEX", msg, key, NULL);
}
return TCL_ERROR;
}
Index: generic/tclInterp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInterp.c,v
retrieving revision 1.70
diff -u -r1.70 tclInterp.c
--- generic/tclInterp.c 28 Nov 2006 22:20:29 -0000 1.70
+++ generic/tclInterp.c 15 Dec 2006 15:13:53 -0000
@@ -971,15 +971,17 @@
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"",
- Tcl_GetString(objv[2]), "\" not found", (char *) NULL);
+ TclGetString(objv[2]), "\" not found", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "ALIAS", aliasName,
+ NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "target interpreter for alias \"",
- aliasName, "\" in path \"", Tcl_GetString(objv[2]),
- "\" is not my descendant", (char *) NULL);
+ aliasName, "\" in path \"", TclGetString(objv[2]),
+ "\" is not my descendant", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1187,8 +1189,8 @@
iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "alias \"", aliasName,
- "\" not found", (char *) NULL);
+ Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
@@ -1249,8 +1251,8 @@
iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == (Tcl_HashEntry *) NULL) {
- Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found",
- (char *) NULL);
+ Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
@@ -1568,8 +1570,10 @@
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
if (hPtr == NULL) {
- Tcl_AppendResult(interp, "alias \"", Tcl_GetString(namePtr),
+ Tcl_AppendResult(interp, "alias \"", TclGetString(namePtr),
"\" not found", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "ALIAS",
+ TclGetString(namePtr), NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
@@ -2035,7 +2039,9 @@
}
if (searchInterp == NULL) {
Tcl_AppendResult(interp, "could not find interpreter \"",
- Tcl_GetString(pathPtr), "\"", (char *) NULL);
+ TclGetString(pathPtr), "\"", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "INTERP",
+ TclGetString(pathPtr), NULL);
}
return searchInterp;
}
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.121
diff -u -r1.121 tclNamesp.c
--- generic/tclNamesp.c 8 Dec 2006 13:50:42 -0000 1.121
+++ generic/tclNamesp.c 15 Dec 2006 15:14:00 -0000
@@ -2317,6 +2317,7 @@
} else if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "NAMESPACE", name, NULL);
}
return NULL;
}
@@ -2502,6 +2503,7 @@
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "COMMAND", name, NULL);
}
return (Tcl_Command) NULL;
}
@@ -2625,6 +2627,7 @@
} else if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "VARIABLE", name, NULL);
}
return (Tcl_Var) NULL;
}
@@ -3078,6 +3081,8 @@
Tcl_AppendResult(interp, "unknown namespace \"",
TclGetString(objv[2]),
"\" in namespace children command", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "NAMESPACE",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
nsPtr = (Namespace *) namespacePtr;
@@ -3342,6 +3347,8 @@
Tcl_AppendResult(interp, "unknown namespace \"",
TclGetString(objv[i]),
"\" in namespace delete command", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "NAMESPACE",
+ TclGetString(objv[i]), NULL);
return TCL_ERROR;
}
}
@@ -3852,6 +3859,8 @@
if (namespacePtr == NULL) {
Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]),
"\" in inscope namespace command", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "NAMESPACE",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
@@ -4027,6 +4036,8 @@
Tcl_AppendResult(interp, "unknown namespace \"",
TclGetString(objv[2]),
"\" in namespace parent command", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "NAMESPACE",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
} else {
@@ -4131,6 +4142,8 @@
if (namespaceList[i] == NULL) {
Tcl_AppendResult(interp, "unknown namespace \"",
TclGetString(nsObjv[i]), "\"", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "NAMESPACE",
+ TclGetString(nsObjv[i]), NULL);
goto badNamespace;
}
}
@@ -6425,6 +6438,8 @@
*/
Tcl_ResetResult(interp);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "ENSEMBLE",
+ TclGetString(objv[1]), NULL);
if (ensemblePtr->subcommandTable.numEntries == 0) {
Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]),
"\": namespace ", ensemblePtr->nsPtr->fullName,
Index: generic/tclPkg.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclPkg.c,v
retrieving revision 1.26
diff -u -r1.26 tclPkg.c
--- generic/tclPkg.c 5 Dec 2006 15:36:12 -0000 1.26
+++ generic/tclPkg.c 15 Dec 2006 15:14:02 -0000
@@ -291,7 +291,9 @@
return NULL;
}
- /* Translate between old and new API, and defer to the new function. */
+ /*
+ * Translate between old and new API, and defer to the new function.
+ */
if (version == NULL) {
res = Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr);
@@ -374,9 +376,9 @@
break;
}
- /*
- * Check whether we're already attempting to load some version
- * of this package (circular dependency detection).
+ /*
+ * Check whether we're already attempting to load some version of this
+ * package (circular dependency detection).
*/
if (pkgPtr->clientData != NULL) {
@@ -717,10 +719,14 @@
if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
NULL) != TCL_OK) {
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "PACKAGE", name,
+ NULL);
return NULL;
} else if (CheckVersionAndConvert(interp, version, &vi,
NULL) != TCL_OK) {
ckfree(pvi);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "PACKAGE", name,
+ NULL);
return NULL;
}
@@ -739,6 +745,7 @@
}
Tcl_AppendResult(interp, "version conflict for package \"", name,
"\": have ", pkgPtr->version, ", need ", version, NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "PACKAGE", name, NULL);
return NULL;
}
}
@@ -749,6 +756,7 @@
} else {
Tcl_AppendResult(interp, "package ", name, " is not present", NULL);
}
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "PACKAGE", name, NULL);
return NULL;
}
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.108
diff -u -r1.108 tclProc.c
--- generic/tclProc.c 28 Nov 2006 22:20:29 -0000 1.108
+++ generic/tclProc.c 15 Dec 2006 15:14:04 -0000
@@ -195,7 +195,8 @@
procPtr->cmdPtr = (Command *) cmd;
- /* TIP #280 Remember the line the procedure body is starting on. In a
+ /*
+ * TIP #280: Remember the line the procedure body is starting on. In a
* Byte code context we ask the engine to provide us with the necessary
* information. This is for the initialization of the byte code compiler
* when the body is used for the first time.
@@ -211,37 +212,46 @@
CmdFrame context = *iPtr->cmdFramePtr;
if (context.type == TCL_LOCATION_BC) {
- TclGetSrcInfoForPc (&context);
- /* May get path in context */
+ TclGetSrcInfoForPc(&context);
+
+ /*
+ * May get path in context
+ */
} else if (context.type == TCL_LOCATION_SOURCE) {
- /* context now holds another reference */
- Tcl_IncrRefCount (context.data.eval.path);
+ /*
+ * Context now holds another reference.
+ */
+
+ Tcl_IncrRefCount(context.data.eval.path);
}
- /* type == TCL_LOCATION_PREBC implies that 'line' is NULL here!
- * We cannot assume that 'line' is valid here, we have to check.
+ /*
+ * type == TCL_LOCATION_PREBC implies that 'line' is NULL here! We
+ * cannot assume that 'line' is valid here, we have to check.
*/
- if ((context.type == TCL_LOCATION_SOURCE) &&
- context.line &&
- (context.nline >= 4) &&
- (context.line [3] >= 0)) {
- int new;
- CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame));
-
- cfPtr->level = -1;
- cfPtr->type = context.type;
- cfPtr->line = (int*) ckalloc (sizeof (int));
- cfPtr->line [0] = context.line [3];
- cfPtr->nline = 1;
+ if ((context.type == TCL_LOCATION_SOURCE) && context.line
+ && (context.nline >= 4) && (context.line[3] >= 0)) {
+ int new;
+ CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+ Tcl_HashEntry *hPtr;
+
+ cfPtr->level = -1;
+ cfPtr->type = context.type;
+ cfPtr->line = (int *) ckalloc(sizeof(int));
+ cfPtr->line[0] = context.line[3];
+ cfPtr->nline = 1;
cfPtr->framePtr = NULL;
- cfPtr->nextPtr = NULL;
+ cfPtr->nextPtr = NULL;
if (context.type == TCL_LOCATION_SOURCE) {
cfPtr->data.eval.path = context.data.eval.path;
- /* Transfer of reference. The reference going away (release of
+
+ /*
+ * Transfer of reference. The reference going away (release of
* the context) is replaced by the reference in the
- * constructed cmdframe */
+ * constructed cmdframe.
+ */
} else {
cfPtr->type = TCL_LOCATION_EVAL;
cfPtr->data.eval.path = NULL;
@@ -250,9 +260,9 @@
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
- Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->linePBodyPtr,
- (char*) procPtr, &new),
- cfPtr);
+ hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr,
+ &new);
+ Tcl_SetHashValue(hPtr, cfPtr);
}
}
@@ -347,7 +357,7 @@
Tcl_Obj *bodyPtr, /* command body */
Proc **procPtrPtr) /* returns: pointer to proc data */
{
- Interp *iPtr = (Interp*)interp;
+ Interp *iPtr = (Interp *) interp;
CONST char **argArray = NULL;
register Proc *procPtr;
@@ -689,7 +699,7 @@
if (framePtr == NULL) {
goto levelError;
}
-
+
*framePtrPtr = framePtr;
return result;
@@ -1377,14 +1387,17 @@
if (localPtr->flags & VAR_IS_ARGS) {
Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
+
varPtr->value.objPtr = listPtr;
Tcl_IncrRefCount(listPtr); /* local var is a reference */
} else if (argCt == numArgs) {
Tcl_Obj *objPtr = argObjs[i];
+
varPtr->value.objPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* local var is a reference */
} else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) {
Tcl_Obj *objPtr = localPtr->defValuePtr;
+
varPtr->value.objPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* local var is a reference */
} else {
@@ -1494,7 +1507,8 @@
procPtr->refCount++;
- /* TIP #280: No need to set the invoking context here. The body has
+ /*
+ * TIP #280: No need to set the invoking context here. The body has
* already been compiled, so the part of CompEvalObj using it is bypassed.
*/
@@ -1615,7 +1629,7 @@
Proc **procPtrPtr) /* Points to storage where a replacement
* (Proc *) value may be written. */
{
- Interp *iPtr = (Interp*)interp;
+ Interp *iPtr = (Interp *) interp;
int i, result;
Tcl_CallFrame *framePtr;
Proc *saveProcPtr;
@@ -1724,7 +1738,10 @@
strcpy(copy->name, localPtr->name);
}
- /* Reset the ClientData */
+ /*
+ * Reset the ClientData
+ */
+
Tcl_GetCommandInfoFromToken(token, &info);
if (info.objClientData == (ClientData) procPtr) {
info.objClientData = (ClientData) new;
@@ -1746,18 +1763,21 @@
(Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0);
if (result == TCL_OK) {
- /* TIP #280. We get the invoking context from the cmdFrame
- * which was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
+ /*
+ * TIP #280. We get the invoking context from the cmdFrame which
+ * was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
*/
- Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
+ Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr,
+ (char *) procPtr);
- /* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
+ /*
+ * Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
*/
- iPtr->invokeWord = 0;
- iPtr->invokeCmdFramePtr = (hePtr
- ? (CmdFrame*) Tcl_GetHashValue (hePtr)
- : NULL);
+
+ iPtr->invokeWord = 0;
+ iPtr->invokeCmdFramePtr =
+ (hePtr ? (CmdFrame *) Tcl_GetHashValue(hePtr) : NULL);
result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
iPtr->invokeCmdFramePtr = NULL;
TclPopStackFrame(interp);
@@ -1909,25 +1929,31 @@
}
ckfree((char *) procPtr);
- /* TIP #280. Release the location data associated with this Proc
+ /*
+ * TIP #280. Release the location data associated with this Proc
* structure, if any. The interpreter may not exist (For example for
* procbody structurues created by tbcload.
*/
- if (!iPtr) return;
+ if (!iPtr) {
+ return;
+ }
- hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
- if (!hePtr) return;
+ hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
+ if (!hePtr) {
+ return;
+ }
- cfPtr = (CmdFrame*) Tcl_GetHashValue (hePtr);
+ cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr);
if (cfPtr->type == TCL_LOCATION_SOURCE) {
- Tcl_DecrRefCount (cfPtr->data.eval.path);
+ Tcl_DecrRefCount(cfPtr->data.eval.path);
cfPtr->data.eval.path = NULL;
}
- ckfree ((char*) cfPtr->line); cfPtr->line = NULL;
- ckfree ((char*) cfPtr);
- Tcl_DeleteHashEntry (hePtr);
+ ckfree((char*) cfPtr->line);
+ cfPtr->line = NULL;
+ ckfree((char*) cfPtr);
+ Tcl_DeleteHashEntry(hePtr);
}
/*
@@ -2192,7 +2218,8 @@
procPtr->cmdPtr = NULL;
- /* TIP #280 Remember the line the apply body is starting on. In a Byte
+ /*
+ * TIP #280 Remember the line the apply body is starting on. In a Byte
* code context we ask the engine to provide us with the necessary
* information. This is for the initialization of the byte code compiler
* when the body is used for the first time.
@@ -2215,41 +2242,54 @@
CmdFrame context = *iPtr->cmdFramePtr;
if (context.type == TCL_LOCATION_BC) {
- TclGetSrcInfoForPc (&context);
- /* May get path in context */
+ TclGetSrcInfoForPc(&context);
+
+ /*
+ * May get path in context.
+ */
} else if (context.type == TCL_LOCATION_SOURCE) {
- /* context now holds another reference */
- Tcl_IncrRefCount (context.data.eval.path);
+ /*
+ * Context now holds another reference.
+ */
+
+ Tcl_IncrRefCount(context.data.eval.path);
}
- /* type == TCL_LOCATION_PREBC implies that 'line' is NULL here!
- * We cannot assume that 'line' is valid here, we have to check.
+ /*
+ * type == TCL_LOCATION_PREBC implies that 'line' is NULL here! We
+ * cannot assume that 'line' is valid here, we have to check.
*/
- if ((context.type == TCL_LOCATION_SOURCE) &&
- context.line &&
- (context.nline >= 2) &&
- (context.line [1] >= 0)) {
- int new, buf [2];
- CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame));
-
- /* Move from approximation (line of list cmd word) to actual
- * location (line of 2nd list element) */
- TclListLines (name, context.line [1], 2, buf);
-
- cfPtr->level = -1;
- cfPtr->type = context.type;
- cfPtr->line = (int*) ckalloc (sizeof (int));
- cfPtr->line [0] = buf [1];
- cfPtr->nline = 1;
+ if ((context.type == TCL_LOCATION_SOURCE)
+ && context.line && (context.nline >= 2)
+ && (context.line [1] >= 0)) {
+ int new, buf[2];
+ CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+ Tcl_HashEntry *hPtr;
+
+ /*
+ * Move from approximation (line of list cmd word) to actual
+ * location (line of 2nd list element)
+ */
+
+ TclListLines(name, context.line[1], 2, buf);
+
+ cfPtr->level = -1;
+ cfPtr->type = context.type;
+ cfPtr->line = (int *) ckalloc(sizeof(int));
+ cfPtr->line[0] = buf[1];
+ cfPtr->nline = 1;
cfPtr->framePtr = NULL;
- cfPtr->nextPtr = NULL;
+ cfPtr->nextPtr = NULL;
if (context.type == TCL_LOCATION_SOURCE) {
cfPtr->data.eval.path = context.data.eval.path;
- /* Transfer of reference. The reference going away (release of
+
+ /*
+ * Transfer of reference. The reference going away (release of
* the context) is replaced by the reference in the
- * constructed cmdframe */
+ * constructed cmdframe.
+ */
} else {
cfPtr->type = TCL_LOCATION_EVAL;
cfPtr->data.eval.path = NULL;
@@ -2258,9 +2298,9 @@
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
- Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->linePBodyPtr,
- (char*) procPtr, &new),
- cfPtr);
+ hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char*) procPtr,
+ &new);
+ Tcl_SetHashValue(hPtr, cfPtr);
}
}
@@ -2371,20 +2411,21 @@
procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
}
- memset (&cmd, 0, sizeof(Command));
+ memset(&cmd, 0, sizeof(Command));
procPtr->cmdPtr = &cmd;
- /* TIP#280 HACK !
+ /*
+ * TIP#280 HACK !
*
- * Using cmd.clientData to remember the 'lambdaPtr' for 'info frame'. The
+ * Using cmd.clientData to remember the 'lambdaPtr' for 'info frame'. The
* InfoFrameCmd will detect this case by testing cmd.hPtr for NULL. This
- * condition holds here because of the 'memset' above, and nowhere
- * else. Regular commands always have a valid 'hPtr', and lambda's never.
+ * condition holds here because of the 'memset' above, and nowhere else.
+ * Regular commands always have a valid 'hPtr', and lambda's never.
*/
cmd.clientData = (ClientData) lambdaPtr;
- Tcl_IncrRefCount (lambdaPtr);
-
+ Tcl_IncrRefCount(lambdaPtr);
+
/*
* Find the namespace where this lambda should run, and push a call frame
* for that namespace. Note that TclObjInterpProc() will pop it.
@@ -2424,10 +2465,13 @@
iPtr->ensembleRewrite.numInsertedObjs = 0;
}
- /* TIP #280 Undo the reference held inside of 'cmd, see HACK above. */
- Tcl_DecrRefCount (lambdaPtr);
+ /*
+ * TIP #280: Undo the reference held inside of 'cmd, see HACK above.
+ */
- return result;
+ Tcl_DecrRefCount(lambdaPtr);
+
+ return result;
}
/*
Index: generic/tclVar.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclVar.c,v
retrieving revision 1.126
diff -u -r1.126 tclVar.c
--- generic/tclVar.c 27 Oct 2006 13:20:33 -0000 1.126
+++ generic/tclVar.c 15 Dec 2006 15:14:08 -0000
@@ -976,6 +976,8 @@
if (hPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclVarErrMsg(interp, arrayName, elName, msg, noSuchElement);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "ELEMENT", elName,
+ NULL);
}
return NULL;
}
@@ -3978,6 +3980,8 @@
if (strcmp(string+offset, varName) != 0) {
Tcl_AppendResult(interp, "search identifier \"", string,
"\" isn't for variable \"", varName, "\"", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "ARRAYSEARCH", string,
+ NULL);
return NULL;
}
@@ -3997,6 +4001,7 @@
}
}
Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", NULL);
+ Tcl_SetErrorCode(interp, "CORE", "LOOKUP", "ARRAYSEARCH", string, NULL);
return NULL;
}
Index: tests/ioCmd.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/ioCmd.test,v
retrieving revision 1.31
diff -u -r1.31 ioCmd.test
--- tests/ioCmd.test 1 Dec 2006 15:55:45 -0000 1.31
+++ tests/ioCmd.test 15 Dec 2006 15:14:13 -0000
@@ -118,7 +118,7 @@
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"}}
test iocmd-4.5 {read command} {
list [catch {read -nonew file4} msg] $msg $::errorCode
-} {1 {can not find channel named "-nonew"} NONE}
+} {1 {can not find channel named "-nonew"} {CORE LOOKUP CHANNEL -nonew}}
test iocmd-4.6 {read command} {
list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
@@ -141,10 +141,8 @@
} {1 {bad argument "foo": should be "nonewline"} NONE}
test iocmd-4.10 {read command} {
list [catch {read file107} msg] $msg $::errorCode
-} {1 {can not find channel named "file107"} NONE}
-
+} {1 {can not find channel named "file107"} {CORE LOOKUP CHANNEL file107}}
set path(test3) [makeFile {} test3]
-
test iocmd-4.11 {read command} {
set f [open $path(test3) w]
set x [list [catch {read $f} msg] $msg $::errorCode]
@@ -245,9 +243,7 @@
test iocmd-8.10 {fconfigure command} {
list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
-
set path(fconfigure.dummy) [makeFile {} fconfigure.dummy]
-
test iocmd-8.11 {fconfigure command} {
set chan [open $path(fconfigure.dummy) r]
set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg]
@@ -266,9 +262,7 @@
close $chan
set res
} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
-
removeFile fconfigure.dummy
-
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
@@ -351,7 +345,7 @@
test iocmd-9.3 {eof command} {
catch {close file100}
list [catch {eof file100} msg] $msg $::errorCode
-} {1 {can not find channel named "file100"} NONE}
+} {1 {can not find channel named "file100"} {CORE LOOKUP CHANNEL file100}}
# The tests for Tcl_ExecObjCmd are in exec.test
@@ -502,7 +496,6 @@
test iocmd-13.9 {errors in open command} {
list [catch {open $path(test1) r++} msg] $msg
} {1 {illegal access mode "r++"}}
-
test iocmd-13.10.1 {open for append, a mode} -setup {
set log [makeFile {} out]
set chans {}
@@ -518,7 +511,6 @@
# Ensure that channels are gone, even if body failed to do so
foreach ch $chans {catch {close $ch}}
} -result {0 1 2 3 4 5 6 7 8 9}
-
test iocmd-13.10.2 {open for append, O_APPEND} -setup {
set log [makeFile {} out]
set chans {}
@@ -537,7 +529,7 @@
test iocmd-14.1 {file id parsing errors} {
list [catch {eof gorp} msg] $msg $::errorCode
-} {1 {can not find channel named "gorp"} NONE}
+} {1 {can not find channel named "gorp"} {CORE LOOKUP CHANNEL gorp}}
test iocmd-14.2 {file id parsing errors} {
list [catch {eof filex} msg] $msg
} {1 {can not find channel named "filex"}}
