From 46ba97a82bfb00034073d7334903cc1417a836dc Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 2 Dec 2008 19:40:40 +0000 Subject: TIP #336 IMPLEMENTATION * generic/tcl.decls: New routines Tcl_(Get|Set)ErrorLine. * generic/tcl.h: Dropped default access to interp->errorLine. * generic/tclCmdAH.c: Restore it with -DUSE_INTERP_ERRORLINE. * generic/tclCmdMZ.c: Updated callers. * generic/tclDictObj.c: * generic/tclIOUtil.c: * generic/tclNamesp.c: * generic/tclOOBasic.c: * generic/tclOODefinedCmds.c: * generic/tclOOMethod.c: * generic/tclProc.c: * generic/tclResult.c: * generic/tclDecls.h: make genstubs * generic/tclStubInit.c: --- ChangeLog | 20 ++++++++++++++++++++ generic/tcl.decls | 10 +++++++++- generic/tcl.h | 6 +++++- generic/tclCmdAH.c | 13 +++++++------ generic/tclCmdMZ.c | 4 ++-- generic/tclDecls.h | 22 +++++++++++++++++++++- generic/tclDictObj.c | 7 ++++--- generic/tclIOUtil.c | 4 ++-- generic/tclNamesp.c | 4 ++-- generic/tclOOBasic.c | 8 ++++---- generic/tclOODefineCmds.c | 8 ++++---- generic/tclOOMethod.c | 10 +++++----- generic/tclProc.c | 8 ++++---- generic/tclResult.c | 41 ++++++++++++++++++++++++++++++++++++++++- generic/tclStubInit.c | 4 +++- 15 files changed, 132 insertions(+), 37 deletions(-) diff --git a/ChangeLog b/ChangeLog index c61aa8e..6b27c8e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,23 @@ +2008-12-02 Don Porter + + TIP #336 IMPLEMENTATION + + * generic/tcl.decls: New routines Tcl_(Get|Set)ErrorLine. + * generic/tcl.h: Dropped default access to interp->errorLine. + * generic/tclCmdAH.c: Restore it with -DUSE_INTERP_ERRORLINE. + * generic/tclCmdMZ.c: Updated callers. + * generic/tclDictObj.c: + * generic/tclIOUtil.c: + * generic/tclNamesp.c: + * generic/tclOOBasic.c: + * generic/tclOODefinedCmds.c: + * generic/tclOOMethod.c: + * generic/tclProc.c: + * generic/tclResult.c: + + * generic/tclDecls.h: make genstubs + * generic/tclStubInit.c: + 2008-12-02 Andreas Kupries * generic/tclIO.c (TclFinalizeIOSubsystem): Replaced Alexandre diff --git a/generic/tcl.decls b/generic/tcl.decls index 715c2ad..b294b91 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -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: tcl.decls,v 1.154 2008/11/17 22:15:34 nijtmans Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.155 2008/12/02 19:40:40 dgp Exp $ library tcl @@ -2204,6 +2204,14 @@ declare 604 generic { int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) } +# TIP 335 +declare 605 generic { + int Tcl_GetErrorLine(Tcl_Interp *interp) +} +declare 606 generic { + void Tcl_SetErrorLine(Tcl_Interp *interp, int value) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tcl.h b/generic/tcl.h index 5354a70..c99ad44 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -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: tcl.h,v 1.279 2008/11/27 08:23:51 ferrieux Exp $ + * RCS: @(#) $Id: tcl.h,v 1.280 2008/12/02 19:40:41 dgp Exp $ */ #ifndef _TCL @@ -476,9 +476,13 @@ typedef struct Tcl_Interp { char* unused3; void (*unused4) (char*); #endif +#ifdef USE_INTERP_ERRORLINE int errorLine; /* When TCL_ERROR is returned, this gives the * line number within the command where the * error occurred (1 if first line). */ +#else + int unused5; +#endif } Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 19ef57e..ead9384 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.110 2008/11/29 18:17:20 dkf Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.111 2008/12/02 19:40:41 dgp Exp $ */ #include "tclInt.h" @@ -221,7 +221,7 @@ Tcl_CaseObjCmd( if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.50s\" arm line %d)", - TclGetString(armPtr), interp->errorLine)); + TclGetString(armPtr), Tcl_GetErrorLine(interp))); } return result; } @@ -312,7 +312,7 @@ CatchObjCmdCallback( if (rewind || Tcl_LimitExceeded(interp)) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"catch\" body line %d)", interp->errorLine)); + "\n (\"catch\" body line %d)", Tcl_GetErrorLine(interp))); return TCL_ERROR; } @@ -702,7 +702,7 @@ EvalCmdErrMsg( { if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"eval\" body line %d)", interp->errorLine)); + "\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp))); } return result; } @@ -1894,7 +1894,8 @@ TclNRForIterCallback( Tcl_ResetResult(interp); break; case TCL_ERROR: - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(msg, interp->errorLine)); + Tcl_AppendObjToErrorInfo(interp, + Tcl_ObjPrintf(msg, Tcl_GetErrorLine(interp))); } return result; } @@ -2100,7 +2101,7 @@ ForeachLoopStep( goto done; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"foreach\" body line %d)", interp->errorLine)); + "\n (\"foreach\" body line %d)", Tcl_GetErrorLine(interp))); default: goto done; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 794b75b..c42370c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.171 2008/10/14 22:37:53 nijtmans Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.172 2008/12/02 19:40:41 dgp Exp $ */ #include "tclInt.h" @@ -3892,7 +3892,7 @@ Tcl_SwitchObjCmd( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s%s\" arm line %d)", (overflow ? limit : patternLength), pattern, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } TclStackFree(interp, ctxPtr); return result; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 2578df2..f75b63e 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.156 2008/11/17 22:15:34 nijtmans Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.157 2008/12/02 19:40:41 dgp Exp $ */ #ifndef _TCLDECLS @@ -3657,6 +3657,16 @@ EXTERN int Tcl_ParseArgsObjv (Tcl_Interp * interp, const Tcl_ArgvInfo * argTable, int * objcPtr, Tcl_Obj *const * objv, Tcl_Obj *** remObjv); #endif +#ifndef Tcl_GetErrorLine_TCL_DECLARED +#define Tcl_GetErrorLine_TCL_DECLARED +/* 605 */ +EXTERN int Tcl_GetErrorLine (Tcl_Interp * interp); +#endif +#ifndef Tcl_SetErrorLine_TCL_DECLARED +#define Tcl_SetErrorLine_TCL_DECLARED +/* 606 */ +EXTERN void Tcl_SetErrorLine (Tcl_Interp * interp, int value); +#endif typedef struct TclStubHooks { const struct TclPlatStubs *tclPlatStubs; @@ -4321,6 +4331,8 @@ typedef struct TclStubs { int (*tcl_SetEnsembleParameterList) (Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * paramList); /* 602 */ int (*tcl_GetEnsembleParameterList) (Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** paramListPtr); /* 603 */ int (*tcl_ParseArgsObjv) (Tcl_Interp * interp, const Tcl_ArgvInfo * argTable, int * objcPtr, Tcl_Obj *const * objv, Tcl_Obj *** remObjv); /* 604 */ + int (*tcl_GetErrorLine) (Tcl_Interp * interp); /* 605 */ + void (*tcl_SetErrorLine) (Tcl_Interp * interp, int value); /* 606 */ } TclStubs; #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) @@ -6813,6 +6825,14 @@ extern const TclStubs *tclStubsPtr; #define Tcl_ParseArgsObjv \ (tclStubsPtr->tcl_ParseArgsObjv) /* 604 */ #endif +#ifndef Tcl_GetErrorLine +#define Tcl_GetErrorLine \ + (tclStubsPtr->tcl_GetErrorLine) /* 605 */ +#endif +#ifndef Tcl_SetErrorLine +#define Tcl_SetErrorLine \ + (tclStubsPtr->tcl_SetErrorLine) /* 606 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 75e1478..bcdc404 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDictObj.c,v 1.70 2008/11/17 22:15:34 nijtmans Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.71 2008/12/02 19:40:41 dgp Exp $ */ #include "tclInt.h" @@ -2508,7 +2508,8 @@ DictForLoopCallback( result = TCL_OK; } else if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"dict for\" body line %d)", interp->errorLine)); + "\n (\"dict for\" body line %d)", + Tcl_GetErrorLine(interp))); } goto done; } @@ -2904,7 +2905,7 @@ DictFilterCmd( case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"dict filter\" script line %d)", - interp->errorLine)); + Tcl_GetErrorLine(interp))); default: goto abnormalResult; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 607397e..7b6a4c8 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.159 2008/11/13 22:34:33 nijtmans Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.160 2008/12/02 19:40:41 dgp Exp $ */ #include "tclInt.h" @@ -1775,7 +1775,7 @@ Tcl_FSEvalFileEx( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", (overflow ? limit : length), pathString, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } end: diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index a88d140..3703118 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -23,7 +23,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.182 2008/11/11 21:54:06 nijtmans Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.183 2008/12/02 19:40:41 dgp Exp $ */ #include "tclInt.h" @@ -3375,7 +3375,7 @@ NsEval_Callback( "\n (in namespace %s \"%.*s%s\" script line %d)", cmd, (overflow ? limit : length), namespacePtr->fullName, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index b52f90c..887e80c 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOBasic.c,v 1.15 2008/11/01 00:04:26 dkf Exp $ + * RCS: @(#) $Id: tclOOBasic.c,v 1.16 2008/12/02 19:40:41 dgp Exp $ */ #ifdef HAVE_CONFIG_H @@ -358,11 +358,11 @@ FinalizeEval( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in \"%s eval\" script line %d)", - TclGetString(objnameObj), interp->errorLine)); + TclGetString(objnameObj), Tcl_GetErrorLine(interp))); } else { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in \"my eval\" script line %d)", - interp->errorLine)); + Tcl_GetErrorLine(interp))); } } @@ -1010,7 +1010,7 @@ UpcatchCallback( iPtr->varFramePtr = savedFramePtr; if (rewind || Tcl_LimitExceeded(interp)) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"UpCatch\" body line %d)", interp->errorLine)); + "\n (\"UpCatch\" body line %d)", Tcl_GetErrorLine(interp))); return TCL_ERROR; } resultObj[0] = Tcl_GetObjResult(interp); diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index a96d267..5b1f354 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOODefineCmds.c,v 1.7 2008/10/31 22:08:32 dkf Exp $ + * RCS: @(#) $Id: tclOODefineCmds.c,v 1.8 2008/12/02 19:40:41 dgp Exp $ */ #ifdef HAVE_CONFIG_H @@ -706,7 +706,7 @@ TclOODefineObjCmd( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in definition script for object \"%.*s%s\" line %d)", (overflow ? limit : length), objName, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; @@ -825,7 +825,7 @@ TclOOObjDefObjCmd( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in definition script for object \"%.*s%s\" line %d)", (overflow ? limit : length), objName, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; @@ -945,7 +945,7 @@ TclOODefineSelfObjCmd( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in definition script for object \"%.*s%s\" line %d)", (overflow ? limit : length), objName, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 34a3172..2606f0a 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOMethod.c,v 1.20 2008/09/24 09:51:47 dkf Exp $ + * RCS: @(#) $Id: tclOOMethod.c,v 1.21 2008/12/02 19:40:41 dgp Exp $ */ #ifdef HAVE_CONFIG_H @@ -1173,7 +1173,7 @@ MethodErrorHandler( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)", kindName, ELLIPSIFY(objectName, objectNameLen), - ELLIPSIFY(methodName, nameLen), interp->errorLine)); + ELLIPSIFY(methodName, nameLen), Tcl_GetErrorLine(interp))); } static void @@ -1187,7 +1187,7 @@ ConstructorErrorHandler( const char *objectName, *kindName; int objectNameLen; - if (interp->errorLine == (int) 0xDEADBEEF) { + if (Tcl_GetErrorLine(interp) == (int) 0xDEADBEEF) { /* * Horrible hack to deal with certain constructors that must not add * information to the error trace. @@ -1211,7 +1211,7 @@ ConstructorErrorHandler( &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" constructor line %d)", kindName, - ELLIPSIFY(objectName, objectNameLen), interp->errorLine)); + ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp))); } static void @@ -1240,7 +1240,7 @@ DestructorErrorHandler( &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" destructor line %d)", kindName, - ELLIPSIFY(objectName, objectNameLen), interp->errorLine)); + ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp))); } /* diff --git a/generic/tclProc.c b/generic/tclProc.c index a7e9531..80c792c 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -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: tclProc.c,v 1.167 2008/10/28 23:29:54 nijtmans Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.168 2008/12/02 19:40:41 dgp Exp $ */ #include "tclInt.h" @@ -903,7 +903,7 @@ Uplevel_Callback( if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"uplevel\" body line %d)", interp->errorLine)); + "\n (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp))); } /* @@ -2091,7 +2091,7 @@ MakeProcError( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (procedure \"%.*s%s\" line %d)", (overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* @@ -2783,7 +2783,7 @@ MakeLambdaError( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (lambda term \"%.*s%s\" line %d)", (overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* diff --git a/generic/tclResult.c b/generic/tclResult.c index 40f0cba..8e85035 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -8,7 +8,7 @@ * 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.51 2008/10/26 18:34:04 dkf Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.52 2008/12/02 19:40:41 dgp Exp $ */ #include "tclInt.h" @@ -1084,6 +1084,45 @@ Tcl_SetObjErrorCode( /* *---------------------------------------------------------------------- * + * Tcl_GetErrorLine -- + * + * Results: + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetErrorLine( + Tcl_Interp *interp) +{ + return ((Interp *) interp)->errorLine; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrorLine -- + * + * Results: + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +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 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a95f056..15cfa2d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.167 2008/10/22 20:23:59 nijtmans Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.168 2008/12/02 19:40:41 dgp Exp $ */ #include "tclInt.h" @@ -1130,6 +1130,8 @@ static const TclStubs tclStubs = { Tcl_SetEnsembleParameterList, /* 602 */ Tcl_GetEnsembleParameterList, /* 603 */ Tcl_ParseArgsObjv, /* 604 */ + Tcl_GetErrorLine, /* 605 */ + Tcl_SetErrorLine, /* 606 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12