From fe3d6b650e607816bf94213b17c95b2c6b1d05f0 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 24 Mar 2011 09:12:17 +0000 Subject: Correct bizarre name of enumeration member. --- generic/tclEvent.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 78bd7b8..a8bab0b 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1479,7 +1479,7 @@ Tcl_UpdateObjCmd( int optionIndex; int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptions {REGEXP_IDLETASKS}; + enum updateOptions {OPT_IDLETASKS}; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; @@ -1489,7 +1489,7 @@ Tcl_UpdateObjCmd( return TCL_ERROR; } switch ((enum updateOptions) optionIndex) { - case REGEXP_IDLETASKS: + case OPT_IDLETASKS: flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: -- cgit v0.12 From 8296df7cb7e4d3398fda3276bb2fc5336a8220ab Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 24 Mar 2011 09:40:31 +0000 Subject: Ensure that any reference to temporary index tables is squelched immediately rather than hanging around to trip us up in the future. --- ChangeLog | 6 ++++++ generic/tclFCmd.c | 10 ++++++++++ 2 files changed, 16 insertions(+) diff --git a/ChangeLog b/ChangeLog index c6554dd..f90c9f2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2011-03-24 Donal K. Fellows + + * generic/tclFCmd.c (TclFileAttrsCmd): Ensure that any reference to + temporary index tables is squelched immediately rather than hanging + around to trip us up in the future. + 2011-03-16 Jan Nijtmans * unix/configure, unix/tcl.m4: SHLIB_LD_LIBS='${LIBS}' for OSF1-V*. diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 88d80a9..5af8630 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -986,6 +986,11 @@ TclFileAttrsCmd(interp, objc, objv) "option", 0, &index) != TCL_OK) { goto end; } + if (numObjStrings != -1 && objv[0]->typePtr != NULL + && objv[0]->typePtr->freeIntRepProc != NULL) { + objv[0]->typePtr->freeIntRepProc(objv[0]); + objv[0]->typePtr = NULL; + } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; @@ -1010,6 +1015,11 @@ TclFileAttrsCmd(interp, objc, objv) "option", 0, &index) != TCL_OK) { goto end; } + if (numObjStrings != -1 && objv[i]->typePtr != NULL + && objv[i]->typePtr->freeIntRepProc != NULL) { + objv[i]->typePtr->freeIntRepProc(objv[i]); + objv[i]->typePtr = NULL; + } if (i + 1 == objc) { Tcl_AppendResult(interp, "value for \"", Tcl_GetString(objv[i]), "\" missing", -- cgit v0.12 From 884ba1c7869af6d659c880a2dc8a9d7a76f034bd Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2011 16:43:38 +0000 Subject: Restored C++ usability to the memory allocation and free macros. --- ChangeLog | 5 +++++ generic/tcl.h | 12 ++++++------ generic/tclThreadAlloc.c | 0 3 files changed, 11 insertions(+), 6 deletions(-) mode change 100644 => 100755 generic/tclThreadAlloc.c diff --git a/ChangeLog b/ChangeLog index c327093..3440a14 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-03-24 Don Porter + + * generic/tcl.h (ckfree,etc.): Restored C++ usability to the memory + allocation and free macros. + 2011-03-24 Donal K. Fellows * generic/tclFCmd.c (TclFileAttrsCmd): Ensure that any reference to diff --git a/generic/tcl.h b/generic/tcl.h index 2abbb1a..b491944 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2405,13 +2405,13 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # define ckalloc(x) \ ((VOID *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__)) # define ckfree(x) \ - Tcl_DbCkfree((VOID *)(x), __FILE__, __LINE__) + Tcl_DbCkfree((char *)(x), __FILE__, __LINE__) # define ckrealloc(x,y) \ - ((VOID *) Tcl_DbCkrealloc((VOID *)(x), (unsigned)(y), __FILE__, __LINE__)) + ((VOID *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) # define attemptckalloc(x) \ ((VOID *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__)) # define attemptckrealloc(x,y) \ - ((VOID *) Tcl_AttemptDbCkrealloc((VOID *)(x), (unsigned)(y), __FILE__, __LINE__)) + ((VOID *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) #else /* !TCL_MEM_DEBUG */ @@ -2424,13 +2424,13 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # define ckalloc(x) \ ((VOID *) Tcl_Alloc((unsigned)(x))) # define ckfree(x) \ - Tcl_Free((VOID *)(x)) + Tcl_Free((char *)(x)) # define ckrealloc(x,y) \ - ((VOID *) Tcl_Realloc((VOID *)(x), (unsigned)(y))) + ((VOID *) Tcl_Realloc((char *)(x), (unsigned)(y))) # define attemptckalloc(x) \ ((VOID *) Tcl_AttemptAlloc((unsigned)(x))) # define attemptckrealloc(x,y) \ - ((VOID *) Tcl_AttemptRealloc((VOID *)(x), (unsigned)(y))) + ((VOID *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y))) # undef Tcl_InitMemory # define Tcl_InitMemory(x) # undef Tcl_DumpActiveMemory diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c old mode 100644 new mode 100755 -- cgit v0.12 From 7f62526237f1fbba269a64a7a4c8a369d7b5e388 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Mar 2011 13:13:26 +0000 Subject: Remove Tclp(Local|Gm)time_unix forwarders, the same can be done directly Some void -> VOID transitions --- generic/tclInt.decls | 10 +- generic/tclIntDecls.h | 8 +- generic/tclIntPlatDecls.h | 15 ++- generic/tclStubInit.c | 8 +- unix/tclUnixTime.c | 281 ++++++++++++++++++++++------------------------ 5 files changed, 158 insertions(+), 164 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index c48cd0d..4fb88c6 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -640,7 +640,7 @@ declare 162 generic { # correct type when calling this procedure. declare 163 generic { - void * TclGetInstructionTable (void) + VOID *TclGetInstructionTable(void) } # ALERT: The argument of 'TclExpandCodeArray' is actually a @@ -648,7 +648,7 @@ declare 163 generic { # "tclInt.h". It is described in "tclCompile.h". declare 164 generic { - void TclExpandCodeArray (void *envPtr) + void TclExpandCodeArray(VOID *envPtr) } # These functions are vfs aware, but are generally only useful internally. @@ -790,13 +790,13 @@ declare 16 mac { int TclMacOSErrorToPosixError(int error) } declare 17 mac { - void TclMacRemoveTimer(void *timerToken) + void TclMacRemoveTimer(VOID *timerToken) } declare 18 mac { - void * TclMacStartTimer(long ms) + VOID *TclMacStartTimer(long ms) } declare 19 mac { - int TclMacTimerExpired(void *timerToken) + int TclMacTimerExpired(VOID *timerToken) } declare 20 mac { int TclMacRegisterResourceFork(short fileRef, Tcl_Obj *tokenPtr, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 453532c..1d831ed 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -465,9 +465,9 @@ EXTERN int TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp, EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_(( ClientData clientData, int flags)); /* 163 */ -EXTERN void * TclGetInstructionTable _ANSI_ARGS_((void)); +EXTERN VOID * TclGetInstructionTable _ANSI_ARGS_((void)); /* 164 */ -EXTERN void TclExpandCodeArray _ANSI_ARGS_((void * envPtr)); +EXTERN void TclExpandCodeArray _ANSI_ARGS_((VOID * envPtr)); /* 165 */ EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); /* 166 */ @@ -722,8 +722,8 @@ typedef struct TclIntStubs { void *reserved160; int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */ void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */ - void * (*tclGetInstructionTable) _ANSI_ARGS_((void)); /* 163 */ - void (*tclExpandCodeArray) _ANSI_ARGS_((void * envPtr)); /* 164 */ + VOID * (*tclGetInstructionTable) _ANSI_ARGS_((void)); /* 163 */ + void (*tclExpandCodeArray) _ANSI_ARGS_((VOID * envPtr)); /* 164 */ void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 165 */ int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj * valuePtr)); /* 166 */ void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 3af099d..35bacf1 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -189,11 +189,11 @@ EXTERN OSErr TclMacInstallExitToShellPatch _ANSI_ARGS_(( /* 16 */ EXTERN int TclMacOSErrorToPosixError _ANSI_ARGS_((int error)); /* 17 */ -EXTERN void TclMacRemoveTimer _ANSI_ARGS_((void * timerToken)); +EXTERN void TclMacRemoveTimer _ANSI_ARGS_((VOID * timerToken)); /* 18 */ -EXTERN void * TclMacStartTimer _ANSI_ARGS_((long ms)); +EXTERN VOID * TclMacStartTimer _ANSI_ARGS_((long ms)); /* 19 */ -EXTERN int TclMacTimerExpired _ANSI_ARGS_((void * timerToken)); +EXTERN int TclMacTimerExpired _ANSI_ARGS_((VOID * timerToken)); /* 20 */ EXTERN int TclMacRegisterResourceFork _ANSI_ARGS_(( short fileRef, Tcl_Obj * tokenPtr, @@ -285,9 +285,9 @@ typedef struct TclIntPlatStubs { void (*tclMacInitExitToShell) _ANSI_ARGS_((int usePatch)); /* 14 */ OSErr (*tclMacInstallExitToShellPatch) _ANSI_ARGS_((ExitToShellProcPtr newProc)); /* 15 */ int (*tclMacOSErrorToPosixError) _ANSI_ARGS_((int error)); /* 16 */ - void (*tclMacRemoveTimer) _ANSI_ARGS_((void * timerToken)); /* 17 */ - void * (*tclMacStartTimer) _ANSI_ARGS_((long ms)); /* 18 */ - int (*tclMacTimerExpired) _ANSI_ARGS_((void * timerToken)); /* 19 */ + void (*tclMacRemoveTimer) _ANSI_ARGS_((VOID * timerToken)); /* 17 */ + VOID * (*tclMacStartTimer) _ANSI_ARGS_((long ms)); /* 18 */ + int (*tclMacTimerExpired) _ANSI_ARGS_((VOID * timerToken)); /* 19 */ int (*tclMacRegisterResourceFork) _ANSI_ARGS_((short fileRef, Tcl_Obj * tokenPtr, int insert)); /* 20 */ short (*tclMacUnRegisterResourceFork) _ANSI_ARGS_((char * tokenPtr, Tcl_Obj * resultPtr)); /* 21 */ int (*tclMacCreateEnv) _ANSI_ARGS_((void)); /* 22 */ @@ -589,4 +589,7 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; /* !END!: Do not edit above this line. */ +#undef TclpLocaltime_unix +#undef TclpGmtime_unix + #endif /* _TCLINTPLATDECLS */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 9d5a401..a81f3e8 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -29,10 +29,10 @@ #undef Tcl_NewStringObj #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory -#if TCL_PRESERVE_BINARY_COMPATABILITY -# undef Tcl_FindHashEntry -# undef Tcl_CreateHashEntry -#endif +#undef Tcl_FindHashEntry +#undef Tcl_CreateHashEntry +#define TclpLocaltime_unix TclpLocaltime +#define TclpGmtime_unix TclpGmtime /* * Keep a record of the original Notifier procedures, created in the diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 68fc779..707dfbc 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -1,25 +1,25 @@ -/* +/* * tclUnixTime.c -- * - * Contains Unix specific versions of Tcl functions that - * obtain time values from the operating system. + * Contains Unix specific versions of Tcl functions that obtain time + * values from the operating system. * * Copyright (c) 1995 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclPort.h" #include #define TM_YEAR_BASE 1900 -#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0)) +#define IsLeapYear(x) (((x)%4 == 0) && ((x)%100 != 0 || (x)%400 == 0)) /* - * TclpGetDate is coded to return a pointer to a 'struct tm'. For - * thread safety, this structure must be in thread-specific data. - * The 'tmKey' variable is the key to this buffer. + * TclpGetDate is coded to return a pointer to a 'struct tm'. For thread + * safety, this structure must be in thread-specific data. The 'tmKey' + * variable is the key to this buffer. */ static Tcl_ThreadDataKey tmKey; @@ -29,29 +29,30 @@ typedef struct ThreadSpecificData { } ThreadSpecificData; /* - * If we fall back on the thread-unsafe versions of gmtime and localtime, - * use this mutex to try to protect them. + * If we fall back on the thread-unsafe versions of gmtime and localtime, use + * this mutex to try to protect them. */ TCL_DECLARE_MUTEX(tmMutex) -static char* lastTZ = NULL; /* Holds the last setting of the - * TZ environment variable, or an - * empty string if the variable was - * not set. */ +static char *lastTZ = NULL; /* Holds the last setting of the TZ + * environment variable, or an empty string if + * the variable was not set. */ -/* Static functions declared in this file */ +/* + * Static functions declared in this file. + */ static void SetTZIfNecessary _ANSI_ARGS_((void)); static void CleanupMemory _ANSI_ARGS_((ClientData)); /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TclpGetSeconds -- * - * This procedure returns the number of seconds from the epoch. On - * most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * This procedure returns the number of seconds from the epoch. On most + * Unix systems the epoch is Midnight Jan 1, 1970 GMT. * * Results: * Number of seconds from the epoch. @@ -59,7 +60,7 @@ static void CleanupMemory _ANSI_ARGS_((ClientData)); * Side effects: * None. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ unsigned long @@ -69,13 +70,13 @@ TclpGetSeconds() } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution - * clock available on the system. There are no garantees on what the - * resolution will be. In Tcl we will call this value a "click". The + * clock available on the system. There are no garantees on what the + * resolution will be. In Tcl we will call this value a "click". The * start time is also system dependant. * * Results: @@ -84,13 +85,14 @@ TclpGetSeconds() * Side effects: * None. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ unsigned long TclpGetClicks() { unsigned long now; + #ifdef NO_GETTOD struct tms dummy; #else @@ -112,13 +114,12 @@ TclpGetClicks() * * TclpGetTimeZone -- * - * Determines the current timezone. The method varies wildly - * between different platform implementations, so its hidden in - * this function. + * Determines the current timezone. The method varies wildly between + * different platform implementations, so its hidden in this function. * * Results: - * The return value is the local time zone, measured in - * minutes away from GMT (-ve for east, +ve for west). + * The return value is the local time zone, measured in minutes away from + * GMT (-ve for east, +ve for west). * * Side effects: * None. @@ -127,102 +128,101 @@ TclpGetClicks() */ int -TclpGetTimeZone (currentTime) - Tcl_WideInt currentTime; +TclpGetTimeZone(currentTime) + Tcl_WideInt currentTime; { + int timeZone; + /* - * We prefer first to use the time zone in "struct tm" if the - * structure contains such a member. Following that, we try - * to locate the external 'timezone' variable and use its value. - * If both of those methods fail, we attempt to convert a known - * time to local time and use the difference from UTC as the local - * time zone. In all cases, we need to undo any Daylight Saving Time - * adjustment. + * We prefer first to use the time zone in "struct tm" if the structure + * contains such a member. Following that, we try to locate the external + * 'timezone' variable and use its value. If both of those methods fail, + * we attempt to convert a known time to local time and use the difference + * from UTC as the local time zone. In all cases, we need to undo any + * Daylight Saving Time adjustment. */ - -#if defined(HAVE_TM_TZADJ) -# define TCL_GOT_TIMEZONE - /* Struct tm contains tm_tzadj - that value may be used. */ +#if defined(HAVE_TM_TZADJ) +#define TCL_GOT_TIMEZONE + /* + * Struct tm contains tm_tzadj - that value may be used. + */ - time_t curTime = (time_t) currentTime; - struct tm *timeDataPtr = TclpLocaltime((TclpTime_t) &curTime); - int timeZone; + time_t curTime = (time_t) currentTime; + struct tm *timeDataPtr = TclpLocaltime((TclpTime_t) &curTime); - timeZone = timeDataPtr->tm_tzadj / 60; + timeZone = timeDataPtr->tm_tzadj / 60; if (timeDataPtr->tm_isdst) { - timeZone += 60; + timeZone += 60; } - - return timeZone; - #endif #if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE) -# define TCL_GOT_TIMEZONE - - /* Struct tm contains tm_gmtoff - that value may be used. */ +#define TCL_GOT_TIMEZONE + /* + * Struct tm contains tm_gmtoff - that value may be used. + */ - time_t curTime = (time_t) currentTime; + time_t curTime = (time_t) currentTime; struct tm *timeDataPtr = TclpLocaltime((TclpTime_t) &curTime); - int timeZone; timeZone = -(timeDataPtr->tm_gmtoff / 60); if (timeDataPtr->tm_isdst) { - timeZone += 60; + timeZone += 60; } - - return timeZone; - #endif #if defined(HAVE_TIMEZONE_VAR) && !defined(TCL_GOT_TIMEZONE) && !defined(USE_DELTA_FOR_TZ) -# define TCL_GOT_TIMEZONE - - int timeZone; - - /* The 'timezone' external var is present and may be used. */ +#define TCL_GOT_TIMEZONE + /* + * The 'timezone' external var is present and may be used. + */ SetTZIfNecessary(); /* - * Note: this is not a typo in "timezone" below! See tzset - * documentation for details. + * Note: this is not a typo in "timezone" below! See tzset documentation + * for details. */ timeZone = timezone / 60; - return timeZone; - #endif -#if !defined(TCL_GOT_TIMEZONE) -#define TCL_GOT_TIMEZONE 1 +#if !defined(TCL_GOT_TIMEZONE) +#define TCL_GOT_TIMEZONE /* * Fallback - determine time zone with a known reference time. */ - int timeZone; time_t tt; struct tm *stm; - tt = 849268800L; /* 1996-11-29 12:00:00 GMT */ - stm = TclpLocaltime((TclpTime_t) &tt); /* eg 1996-11-29 6:00:00 CST6CDT */ - /* The calculation below assumes a max of +12 or -12 hours from GMT */ + + tt = 849268800L; /* 1996-11-29 12:00:00 GMT */ + stm = TclpLocaltime((TclpTime_t) &tt); /* eg 1996-11-29 6:00:00 CST6CDT */ + + /* + * The calculation below assumes a max of +12 or -12 hours from GMT. + */ + timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min); - if ( stm -> tm_isdst ) { - timeZone += 60; + if (stm->tm_isdst) { + timeZone += 60; } - return timeZone; /* eg +360 for CST6CDT */ + + /* + * Now have offset for our known reference time, eg +360 for CST6CDT. + */ #endif #ifndef TCL_GOT_TIMEZONE /* - * Cause compile error, we don't know how to get timezone. + * Cause fatal compile error, we don't know how to get timezone. */ -#error autoconf did not figure out how to determine the timezone. - +#error autoconf did not figure out how to determine the timezone. #endif + return timeZone; } /* @@ -230,8 +230,8 @@ TclpGetTimeZone (currentTime) * * Tcl_GetTime -- * - * Gets the current system time in seconds and microseconds - * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * Gets the current system time in seconds and microseconds since the + * beginning of the epoch: 00:00 UCT, January 1, 1970. * * Results: * Returns the current time in timePtr. @@ -258,9 +258,9 @@ Tcl_GetTime(timePtr) * * TclpGetDate -- * - * This function converts between seconds and struct tm. If - * useGMT is true, then the returned date will be in Greenwich - * Mean Time (GMT). Otherwise, it will be in the local time zone. + * This function converts between seconds and struct tm. If useGMT is + * true, then the returned date will be in Greenwich Mean Time (GMT). + * Otherwise, it will be in the local time zone. * * Results: * Returns a static tm structure. @@ -339,7 +339,7 @@ TclpStrftime(s, maxsize, format, t, useGMT) */ struct tm * -TclpGmtime( tt ) +TclpGmtime(tt) TclpTime_t_CONST tt; { CONST time_t *timePtr = (CONST time_t *) tt; @@ -350,26 +350,17 @@ TclpGmtime( tt ) * Get a thread-local buffer to hold the returned time. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT( &tmKey ); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); #ifdef HAVE_GMTIME_R - gmtime_r(timePtr, &( tsdPtr->gmtime_buf )); + gmtime_r(timePtr, &(tsdPtr->gmtime_buf)); #else - Tcl_MutexLock( &tmMutex ); - memcpy( (VOID *) &( tsdPtr->gmtime_buf ), - (VOID *) gmtime( timePtr ), - sizeof( struct tm ) ); - Tcl_MutexUnlock( &tmMutex ); -#endif - return &( tsdPtr->gmtime_buf ); -} -/* - * Forwarder for obsolete item in Stubs - */ -struct tm* -TclpGmtime_unix( timePtr ) - TclpTime_t_CONST timePtr; -{ - return TclpGmtime( timePtr ); + Tcl_MutexLock(&tmMutex); + memcpy((VOID *) &(tsdPtr->gmtime_buf), + (VOID *) gmtime(timePtr), + sizeof(struct tm)); + Tcl_MutexUnlock(&tmMutex); +#endif + return &(tsdPtr->gmtime_buf); } /* @@ -390,7 +381,7 @@ TclpGmtime_unix( timePtr ) */ struct tm * -TclpLocaltime( tt ) +TclpLocaltime(tt) TclpTime_t_CONST tt; { CONST time_t *timePtr = (CONST time_t *) tt; @@ -400,77 +391,68 @@ TclpLocaltime( tt ) * Get a thread-local buffer to hold the returned time. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT( &tmKey ); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey); SetTZIfNecessary(); #ifdef HAVE_LOCALTIME_R - localtime_r( timePtr, &( tsdPtr->localtime_buf ) ); + localtime_r(timePtr, &(tsdPtr->localtime_buf)); #else - Tcl_MutexLock( &tmMutex ); - memcpy( (VOID *) &( tsdPtr -> localtime_buf ), - (VOID *) localtime( timePtr ), - sizeof( struct tm ) ); - Tcl_MutexUnlock( &tmMutex ); -#endif - return &( tsdPtr->localtime_buf ); -} -/* - * Forwarder for obsolete item in Stubs - */ -struct tm* -TclpLocaltime_unix( timePtr ) - TclpTime_t_CONST timePtr; -{ - return TclpLocaltime( timePtr ); + Tcl_MutexLock(&tmMutex); + memcpy((VOID *) &(tsdPtr -> localtime_buf), + (VOID *) localtime(timePtr), + sizeof(struct tm)); + Tcl_MutexUnlock(&tmMutex); +#endif + return &(tsdPtr->localtime_buf); } - + /* *---------------------------------------------------------------------- * * SetTZIfNecessary -- * - * Determines whether a call to 'tzset' is needed prior to the - * next call to 'localtime' or examination of the 'timezone' variable. + * Determines whether a call to 'tzset' is needed prior to the next call + * to 'localtime' or examination of the 'timezone' variable. * * Results: * None. * * Side effects: - * If 'tzset' has never been called in the current process, or if - * the value of the environment variable TZ has changed since the - * last call to 'tzset', then 'tzset' is called again. + * If 'tzset' has never been called in the current process, or if the + * value of the environment variable TZ has changed since the last call + * to 'tzset', then 'tzset' is called again. * *---------------------------------------------------------------------- */ static void -SetTZIfNecessary() { +SetTZIfNecessary() +{ + CONST char *newTZ = getenv("TZ"); - CONST char* newTZ = getenv( "TZ" ); Tcl_MutexLock(&tmMutex); - if ( newTZ == NULL ) { + if (newTZ == NULL) { newTZ = ""; } - if ( lastTZ == NULL || strcmp( lastTZ, newTZ ) ) { - tzset(); - if ( lastTZ == NULL ) { - Tcl_CreateExitHandler( CleanupMemory, (ClientData) NULL ); + if (lastTZ == NULL || strcmp(lastTZ, newTZ)) { + tzset(); + if (lastTZ == NULL) { + Tcl_CreateExitHandler(CleanupMemory, (ClientData) NULL); } else { - Tcl_Free( lastTZ ); + Tcl_Free(lastTZ); } - lastTZ = ckalloc( strlen( newTZ ) + 1 ); - strcpy( lastTZ, newTZ ); + lastTZ = ckalloc(strlen(newTZ) + 1); + strcpy(lastTZ, newTZ); } Tcl_MutexUnlock(&tmMutex); - } - + /* *---------------------------------------------------------------------- * * CleanupMemory -- * - * Releases the private copy of the TZ environment variable - * upon exit from Tcl. + * Releases the private copy of the TZ environment variable upon exit + * from Tcl. * * Results: * None. @@ -482,7 +464,16 @@ SetTZIfNecessary() { */ static void -CleanupMemory( ClientData ignored ) +CleanupMemory(ignored) + ClientData ignored; { - ckfree( lastTZ ); + ckfree(lastTZ); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ -- cgit v0.12 From 5964f0af379da6d133cf236fa9ad9eb9a7fc39fb Mon Sep 17 00:00:00 2001 From: jan Date: Fri, 25 Mar 2011 21:16:15 +0000 Subject: [Bug 3007895]: Tcl_(Find|Create)HashEntry stub entries can never be called. They still cannot be called (no change in functionality), but at least they now do exactly the same as the Tcl_(Find|Create)HashEntry macro's, so the confusion addressed in this Bug report is gone. Merged --cherrypick from Tcl8.5 (2010-12-31,e75735ef76) --- ChangeLog | 9 +++++++++ generic/tclHash.c | 32 ++++++++++++++++++++++++++++++-- 2 files changed, 39 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index f90c9f2..9875500 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2010-03-25 Jan Nijtmans + + * generic/tclHash.c: [Bug 3007895]: Tcl_(Find|Create)HashEntry + stub entries can never be called. They still cannot be called + (no change in functionality), but at least they now do + exactly the same as the Tcl_(Find|Create)HashEntry macro's, + so the confusion addressed in this Bug report is gone. + Merged --cherrypick from Tcl8.5 (2010-12-31,e75735ef76) + 2011-03-24 Donal K. Fellows * generic/tclFCmd.c (TclFileAttrsCmd): Ensure that any reference to diff --git a/generic/tclHash.c b/generic/tclHash.c index 716d251..53d9919 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -90,6 +90,11 @@ static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key)); static Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key, int *newPtr)); +static Tcl_HashEntry * FindHashEntry _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key)); +static Tcl_HashEntry * CreateHashEntry _ANSI_ARGS_((Tcl_HashTable *tablePtr, + CONST char *key, int *newPtr)); + #endif static void RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr)); @@ -204,8 +209,8 @@ Tcl_InitCustomHashTable(tablePtr, keyType, typePtr) tablePtr->mask = 3; tablePtr->keyType = keyType; #if TCL_PRESERVE_BINARY_COMPATABILITY - tablePtr->findProc = Tcl_FindHashEntry; - tablePtr->createProc = Tcl_CreateHashEntry; + tablePtr->findProc = FindHashEntry; + tablePtr->createProc = CreateHashEntry; if (typePtr == NULL) { /* @@ -272,6 +277,16 @@ Tcl_HashEntry * Tcl_FindHashEntry(tablePtr, key) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ CONST char *key; /* Key to use to find matching entry. */ +#if TCL_PRESERVE_BINARY_COMPATABILITY +{ + return tablePtr->findProc(tablePtr, key); +} + +static Tcl_HashEntry * +FindHashEntry(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + CONST char *key; /* Key to use to find matching entry. */ +#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */ { register Tcl_HashEntry *hPtr; Tcl_HashKeyType *typePtr; @@ -371,6 +386,19 @@ Tcl_CreateHashEntry(tablePtr, key, newPtr) * entry. */ int *newPtr; /* Store info here telling whether a new * entry was created. */ +#if TCL_PRESERVE_BINARY_COMPATABILITY +{ + return tablePtr->createProc(tablePtr, key, newPtr); +} + +static Tcl_HashEntry * +CreateHashEntry(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + CONST char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */ { register Tcl_HashEntry *hPtr; Tcl_HashKeyType *typePtr; -- cgit v0.12 From f6e39f12097065e62da6885b91213f473f1ae69e Mon Sep 17 00:00:00 2001 From: jan Date: Sat, 26 Mar 2011 06:25:03 +0000 Subject: The -debug:full option is not supported when using the modern versions of link.exe included with MSVC, use -debug instead --- win/configure | 2 +- win/tcl.m4 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/win/configure b/win/configure index f67e4b7..f7da2f0 100755 --- a/win/configure +++ b/win/configure @@ -1866,7 +1866,7 @@ EOF EXTRA_CFLAGS="" CFLAGS_WARNING="-W3" - LDFLAGS_DEBUG="-debug:full" + LDFLAGS_DEBUG="-debug" LDFLAGS_OPTIMIZE="-release" # Specify the CC output file names based on the target name diff --git a/win/tcl.m4 b/win/tcl.m4 index 7fe2ae3..a766b7c 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -747,7 +747,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ EXTRA_CFLAGS="" CFLAGS_WARNING="-W3" - LDFLAGS_DEBUG="-debug:full" + LDFLAGS_DEBUG="-debug" LDFLAGS_OPTIMIZE="-release" # Specify the CC output file names based on the target name -- cgit v0.12 From 77029bd1e96f8df35c93b67699e5aee7c4546d72 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 26 Mar 2011 11:53:59 +0000 Subject: Reduce the number of casts used to manage Tcl_Obj internal representations. --- ChangeLog | 7 +++ generic/tcl.h | 13 +++-- generic/tclCompExpr.c | 2 +- generic/tclCompile.c | 2 +- generic/tclExecute.c | 147 +++++++++++++++++++++++-------------------------- generic/tclListObj.c | 124 +++++++++++++++++++++-------------------- generic/tclNamesp.c | 6 +- generic/tclObj.c | 2 +- generic/tclStringObj.c | 5 +- generic/tclTestObj.c | 10 ++-- generic/tclUtil.c | 2 +- 11 files changed, 162 insertions(+), 158 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3440a14..051880e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2011-03-26 Donal K. Fellows + + * generic/tclCompExpr.c, generic/tclCompile.c, generic/tclExecute.c: + * generic/tclListObj.c, generic/tclNamesp.c, generic/tclObj.c: + * generic/tclStringObj.c, generic/tclUtil.c: Reduce the number of + casts used to manage Tcl_Obj internal representations. + 2011-03-24 Don Porter * generic/tcl.h (ckfree,etc.): Restored C++ usability to the memory diff --git a/generic/tcl.h b/generic/tcl.h index b491944..3285c3c 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -799,11 +799,14 @@ typedef struct Tcl_Obj { void *ptr1; void *ptr2; } twoPtrValue; - struct { /* - internal rep as a wide int, tightly - * packed fields. */ - void *ptr; /* Pointer to digits. */ - unsigned long value;/* Alloc, used, and signum packed into a - * single word. */ + struct { /* - internal rep as a pointer and a long, + * the main use of which is a bignum's + * tightly packed fields, where the alloc, + * used and signum flags are packed into a + * single word with everything else hung + * off the pointer. */ + void *ptr; + unsigned long value; } ptrAndLongRep; } internalRep; } Tcl_Obj; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index a07d6df..d1d7403 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2152,7 +2152,7 @@ ExecConstantExprTree( TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); - byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr; + byteCodePtr = byteCodeObj->internalRep.otherValuePtr; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); Tcl_DecrRefCount(byteCodeObj); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index aed9e3b..5565342 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1001,7 +1001,7 @@ CompileSubstObj( if (objPtr->typePtr == &substCodeType) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - codePtr = (ByteCode *) objPtr->internalRep.ptrAndLongRep.ptr; + codePtr = objPtr->internalRep.ptrAndLongRep.ptr; if ((unsigned long)flags != objPtr->internalRep.ptrAndLongRep.value || ((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 26d3e04..f1b8504 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -189,7 +189,7 @@ typedef struct TEBCdata { TclNRAddCallback(interp, TEBCresume, TD, \ INT2PTR(1), NULL, NULL) -#define TEBC_DATA_DIG() \ +#define TEBC_DATA_DIG() \ pc = TD->pc; \ cleanup = TD->cleanup; \ tosPtr = esPtr->tosPtr @@ -197,15 +197,15 @@ typedef struct TEBCdata { #define PUSH_TAUX_OBJ(objPtr) \ do { \ - objPtr->internalRep.twoPtrValue.ptr2 = auxObjList; \ + objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \ auxObjList = objPtr; \ } while (0) #define POP_TAUX_OBJ() \ - do { \ - tmpPtr = auxObjList; \ - auxObjList = (Tcl_Obj *) tmpPtr->internalRep.twoPtrValue.ptr2; \ - Tcl_DecrRefCount(tmpPtr); \ + do { \ + tmpPtr = auxObjList; \ + auxObjList = tmpPtr->internalRep.ptrAndLongRep.ptr; \ + Tcl_DecrRefCount(tmpPtr); \ } while (0) /* @@ -1460,7 +1460,7 @@ CompileExprObj( if (objPtr->typePtr == &exprCodeType) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1500,7 +1500,7 @@ CompileExprObj( TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.otherValuePtr; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1572,7 +1572,7 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = objPtr->internalRep.otherValuePtr; objPtr->typePtr = NULL; objPtr->internalRep.otherValuePtr = NULL; @@ -1633,7 +1633,7 @@ TclCompileObj( * here. */ - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1691,67 +1691,59 @@ TclCompileObj( { Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); + ExtCmdLoc *eclPtr; + CmdFrame *ctxPtr; + int redo; - if (hePtr) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); - int redo = 0; - - if (invoker) { - CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame)); - *ctxPtr = *invoker; + if (!hePtr || !invoker) { + return codePtr; + } - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr used instead - */ + eclPtr = Tcl_GetHashValue(hePtr); + redo = 0; + ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + *ctxPtr = *invoker; - TclGetSrcInfoForPc(ctxPtr); - if (ctxPtr->type == TCL_LOCATION_SOURCE) { - /* - * The reference made by 'TclGetSrcInfoForPc' is - * dead. - */ + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr used instead + */ - Tcl_DecrRefCount(ctxPtr->data.eval.path); - ctxPtr->data.eval.path = NULL; - } - } + TclGetSrcInfoForPc(ctxPtr); + if (ctxPtr->type == TCL_LOCATION_SOURCE) { + /* + * The reference made by 'TclGetSrcInfoForPc' is dead. + */ - if (word < ctxPtr->nline) { - /* - * Note: We do not care if the line[word] is -1. This - * is a difference and requires a recompile (location - * changed from absolute to relative, literal is used - * fixed and through variable) - * - * Example: - * test info-32.0 using literal of info-24.8 - * (dict with ... vs set body ...). - */ + Tcl_DecrRefCount(ctxPtr->data.eval.path); + ctxPtr->data.eval.path = NULL; + } + } - redo = ((eclPtr->type == TCL_LOCATION_SOURCE) - && (eclPtr->start != ctxPtr->line[word])) - || ((eclPtr->type == TCL_LOCATION_BC) - && (ctxPtr->type == TCL_LOCATION_SOURCE)); - } + if (word < ctxPtr->nline) { + /* + * Note: We do not care if the line[word] is -1. This is a + * difference and requires a recompile (location changed from + * absolute to relative, literal is used fixed and through + * variable) + * + * Example: + * test info-32.0 using literal of info-24.8 + * (dict with ... vs set body ...). + */ - TclStackFree(interp, ctxPtr); - } + redo = ((eclPtr->type == TCL_LOCATION_SOURCE) + && (eclPtr->start != ctxPtr->line[word])) + || ((eclPtr->type == TCL_LOCATION_BC) + && (ctxPtr->type == TCL_LOCATION_SOURCE)); + } - if (redo) { - goto recompileObj; - } + TclStackFree(interp, ctxPtr); + if (!redo) { + return codePtr; } } - - /* - * Increment the code's ref count while it is being executed. If - * afterwards no references to it remain, free the code. - */ - - runCompiledObj: - return codePtr; } recompileObj: @@ -1773,7 +1765,7 @@ TclCompileObj( codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } - goto runCompiledObj; + return codePtr; } /* @@ -2121,8 +2113,8 @@ TEBCresume( } #endif /* - * Push the call's object result and continue execution with - * the next instruction. + * Push the call's object result and continue execution with the + * next instruction. */ TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", @@ -2132,15 +2124,13 @@ TEBCresume( /* * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult - * to avoid any side effects caused by the resetting of - * errorInfo and errorCode [Bug 804681], which are not needed - * here. We chose instead to manipulate the interp's object - * result directly. + * large objects [Bug 781585]. We do not call Tcl_ResetResult to + * avoid any side effects caused by the resetting of errorInfo and + * errorCode [Bug 804681], which are not needed here. We chose + * instead to manipulate the interp's object result directly. * - * Note that the result object is now in objResultPtr, it - * keeps the refCount it had in its role of - * iPtr->objResultPtr. + * Note that the result object is now in objResultPtr, it keeps + * the refCount it had in its role of iPtr->objResultPtr. */ TclNewObj(objPtr); @@ -2637,7 +2627,7 @@ TEBCresume( */ TclNewObj(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) CURR_DEPTH; + objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; PUSH_TAUX_OBJ(objPtr); NEXT_INST_F(1, 0, 0); @@ -2727,8 +2717,7 @@ TEBCresume( case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1; + objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; POP_TAUX_OBJ(); if (objc) { pcAdjustment = 1; @@ -4415,6 +4404,7 @@ TEBCresume( * strings. We can use memcmp in all (n)eq cases because we * don't need to worry about lexical LE/BE variance. */ + typedef int (*memCmpFn_t)(const void*, const void*, size_t); memCmpFn_t memCmpFn; int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ) @@ -6259,7 +6249,8 @@ TEBCresume( bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); DECACHE_STACK_INFO(); - TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr); + TclLogCommandInfo(interp, codePtr->source, bytes, + bytes ? length : 0, pcBeg, tosPtr); CACHE_STACK_INFO(); } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -6270,8 +6261,8 @@ TEBCresume( */ while (auxObjList) { - if ((catchTop != initCatchTop) && (*catchTop > - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) { + if ((catchTop != initCatchTop) && + (*catchTop>auxObjList->internalRep.ptrAndLongRep.value)) { break; } POP_TAUX_OBJ(); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 46710d6..b27163d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -181,7 +181,7 @@ Tcl_NewListObj( */ Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; listPtr->internalRep.twoPtrValue.ptr2 = NULL; listPtr->typePtr = &tclListType; listRepPtr->refCount++; @@ -253,7 +253,7 @@ Tcl_DbNewListObj( */ Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; listPtr->internalRep.twoPtrValue.ptr2 = NULL; listPtr->typePtr = &tclListType; listRepPtr->refCount++; @@ -329,7 +329,7 @@ Tcl_SetListObj( if (!listRepPtr) { Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj"); } - objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + objPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclListType; listRepPtr->refCount++; @@ -446,7 +446,7 @@ Tcl_ListObjGetElements( return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; @@ -564,7 +564,7 @@ Tcl_ListObjAppendElement( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; @@ -674,7 +674,7 @@ Tcl_ListObjIndex( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { @@ -729,7 +729,7 @@ Tcl_ListObjLength( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; *intPtr = listRepPtr->elemCount; return TCL_OK; } @@ -816,7 +816,7 @@ Tcl_ListObjReplace( * Resist any temptation to optimize this case. */ - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -887,7 +887,7 @@ Tcl_ListObjReplace( Tcl_Panic("Not enough memory to allocate list"); } - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; @@ -1228,8 +1228,8 @@ TclLsetList( * * Results: * Returns the new value of the list variable, or NULL if an error - * occurred. The returned object includes one reference count for - * the pointer returned. + * occurred. The returned object includes one reference count for the + * pointer returned. * * Side effects: * On entry, the reference count of the variable value does not reflect @@ -1275,8 +1275,8 @@ TclLsetFlat( Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; /* - * If there are no indices, simply return the new value. - * (Without indices, [lset] is a synonym for [set]. + * If there are no indices, simply return the new value. (Without + * indices, [lset] is a synonym for [set]. */ if (indexCount == 0) { @@ -1285,14 +1285,14 @@ TclLsetFlat( } /* - * If the list is shared, make a copy we can modify (copy-on-write). - * We use Tcl_DuplicateObj() instead of TclListObjCopy() for a few - * reasons: 1) we have not yet confirmed listPtr is actually a list; - * 2) We make a verbatim copy of any existing string rep, and when - * we combine that with the delayed invalidation of string reps of - * modified Tcl_Obj's implemented below, the outcome is that any - * error condition that causes this routine to return NULL, will - * leave the string rep of listPtr and all elements to be unchanged. + * If the list is shared, make a copy we can modify (copy-on-write). We + * use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons: + * 1) we have not yet confirmed listPtr is actually a list; 2) We make a + * verbatim copy of any existing string rep, and when we combine that with + * the delayed invalidation of string reps of modified Tcl_Obj's + * implemented below, the outcome is that any error condition that causes + * this routine to return NULL, will leave the string rep of listPtr and + * all elements to be unchanged. */ subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr; @@ -1306,8 +1306,8 @@ TclLsetFlat( chainPtr = NULL; /* - * Loop through all the index arguments, and for each one dive - * into the appropriate sublist. + * Loop through all the index arguments, and for each one dive into the + * appropriate sublist. */ do { @@ -1343,10 +1343,10 @@ TclLsetFlat( } /* - * No error conditions. As long as we're not yet on the last - * index, determine the next sublist for the next pass through - * the loop, and take steps to make sure it is an unshared copy, - * as we intend to modify it. + * No error conditions. As long as we're not yet on the last index, + * determine the next sublist for the next pass through the loop, and + * take steps to make sure it is an unshared copy, as we intend to + * modify it. */ result = TCL_OK; @@ -1366,8 +1366,8 @@ TclLsetFlat( * we know to be unshared. This call will also deal with the * situation where parentList shares its intrep with other * Tcl_Obj's. Dealing with the shared intrep case can cause - * subListPtr to become shared again, so detect that case and - * make and store another copy. + * subListPtr to become shared again, so detect that case and make + * and store another copy. */ if (index == elemCount) { @@ -1381,61 +1381,67 @@ TclLsetFlat( } /* - * The TclListObjSetElement() calls do not spoil the string - * rep of parentList, and that's fine for now, since all we've - * done so far is replace a list element with an unshared copy. - * The list value remains the same, so the string rep. is still - * valid, and unchanged, which is good because if this whole - * routine returns NULL, we'd like to leave no change to the - * value of the lset variable. Later on, when we set valuePtr - * in its proper place, then all containing lists will have - * their values changed, and will need their string reps spoiled. - * We maintain a list of all those Tcl_Obj's (via a little intrep - * surgery) so we can spoil them at that time. + * The TclListObjSetElement() calls do not spoil the string rep of + * parentList, and that's fine for now, since all we've done so + * far is replace a list element with an unshared copy. The list + * value remains the same, so the string rep. is still valid, and + * unchanged, which is good because if this whole routine returns + * NULL, we'd like to leave no change to the value of the lset + * variable. Later on, when we set valuePtr in its proper place, + * then all containing lists will have their values changed, and + * will need their string reps spoiled. We maintain a list of all + * those Tcl_Obj's (via a little intrep surgery) so we can spoil + * them at that time. */ - parentList->internalRep.twoPtrValue.ptr2 = (void *) chainPtr; + parentList->internalRep.twoPtrValue.ptr2 = chainPtr; chainPtr = parentList; } } while (indexCount > 0); /* - * Either we've detected and error condition, and exited the loop - * with result == TCL_ERROR, or we've successfully reached the last - * index, and we're ready to store valuePtr. In either case, we - * need to clean up our string spoiling list of Tcl_Obj's. + * Either we've detected and error condition, and exited the loop with + * result == TCL_ERROR, or we've successfully reached the last index, and + * we're ready to store valuePtr. In either case, we need to clean up our + * string spoiling list of Tcl_Obj's. */ while (chainPtr) { Tcl_Obj *objPtr = chainPtr; if (result == TCL_OK) { - /* - * We're going to store valuePtr, so spoil string reps - * of all containing lists. + * We're going to store valuePtr, so spoil string reps of all + * containing lists. */ Tcl_InvalidateStringRep(objPtr); } - /* Clear away our intrep surgery mess */ - chainPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + /* + * Clear away our intrep surgery mess. + */ + + chainPtr = objPtr->internalRep.twoPtrValue.ptr2; objPtr->internalRep.twoPtrValue.ptr2 = NULL; } if (result != TCL_OK) { /* - * Error return; message is already in interp. Clean up - * any excess memory. + * Error return; message is already in interp. Clean up any excess + * memory. */ + if (retValuePtr != listPtr) { Tcl_DecrRefCount(retValuePtr); } return NULL; } - /* Store valuePtr in proper sublist and return */ + /* + * Store valuePtr in proper sublist and return. + */ + Tcl_ListObjLength(NULL, subListPtr, &len); if (index == len) { Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); @@ -1513,7 +1519,7 @@ TclListObjSetElement( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; elemCount = listRepPtr->elemCount; elemPtrs = &listRepPtr->elements; @@ -1550,7 +1556,7 @@ TclListObjSetElement( } listRepPtr->refCount++; listRepPtr->elemCount = elemCount; - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; oldListRepPtr->refCount--; } @@ -1598,7 +1604,7 @@ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + register List *listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; register Tcl_Obj **elemPtrs = &listRepPtr->elements; register Tcl_Obj *objPtr; int numElems = listRepPtr->elemCount; @@ -1639,10 +1645,10 @@ DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = srcPtr->internalRep.twoPtrValue.ptr1; listRepPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &tclListType; } @@ -1861,7 +1867,7 @@ UpdateStringOfList( { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr; - List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; int numElems = listRepPtr->elemCount; register int i; const char *elem; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index ad233b9..0f1eb4d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -2798,18 +2798,18 @@ GetNamespaceFromObj( * cross interps. */ - resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && (!refNsPtr || ((interp == refNsPtr->interp) && - (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))) { + (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 5fc8142..321ed67 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4397,7 +4397,7 @@ SetCmdNameFromAny( if (cmdPtr) { cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + resPtr = objPtr->internalRep.otherValuePtr; if ((objPtr->typePtr == &tclCmdNameType) && resPtr && (resPtr->refCount == 1)) { /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 7cdbb3e..cf635bc 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -134,10 +134,9 @@ typedef struct String { #define stringAlloc(numChars) \ (String *) ckalloc((unsigned) STRING_SIZE(numChars) ) #define stringRealloc(ptr, numChars) \ - (String *) ckrealloc((char *) ptr, (unsigned) STRING_SIZE(numChars) ) + (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define stringAttemptRealloc(ptr, numChars) \ - (String *) attemptckrealloc((char *) ptr, \ - (unsigned) STRING_SIZE(numChars) ) + (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define GET_STRING(objPtr) \ ((String *) (objPtr)->internalRep.otherValuePtr) #define SET_STRING(objPtr, stringPtr) \ diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index ca8545a..1ef1dc3 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -523,7 +523,7 @@ TestindexobjCmd( } Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); - indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr; + indexRep = objv[1]->internalRep.otherValuePtr; indexRep->index = index2; result = Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); @@ -560,7 +560,7 @@ TestindexobjCmd( if (objv[3]->typePtr != NULL && !strcmp("index", objv[3]->typePtr->name)) { - indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr; + indexRep = objv[3]->internalRep.otherValuePtr; if (indexRep->tablePtr == (void *) argv) { objv[3]->typePtr->freeIntRepProc(objv[3]); objv[3]->typePtr = NULL; @@ -1200,8 +1200,7 @@ TeststringobjCmd( if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); - strPtr = (TestString *) - (varPtr[varIndex])->internalRep.otherValuePtr; + strPtr = varPtr[varIndex]->internalRep.otherValuePtr; length = (int) strPtr->allocated; } else { length = -1; @@ -1255,8 +1254,7 @@ TeststringobjCmd( if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); - strPtr = (TestString *) - (varPtr[varIndex])->internalRep.otherValuePtr; + strPtr = varPtr[varIndex]->internalRep.otherValuePtr; length = strPtr->maxChars; } else { length = -1; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index f41830a..69bd4d2 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1057,7 +1057,7 @@ Tcl_ConcatObj( continue; } } - listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) { break; } -- cgit v0.12 From a4188bb98c1fdf3fff44c3552a26944064b0e8b1 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 26 Mar 2011 11:58:37 +0000 Subject: Squelch another unnecessary cast. --- generic/tclNamesp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 0f1eb4d..62ead7d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -911,7 +911,7 @@ Tcl_DeleteNamespace( for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL;) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + cmdPtr = Tcl_GetHashValue(entryPtr); if (cmdPtr->nreProc == NRInterpCoroutine) { Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, (Tcl_Command) cmdPtr); -- cgit v0.12 From 5d8e6c3cce8cdfbf23d812e1048233a2357c8edc Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 26 Mar 2011 12:12:14 +0000 Subject: More generation of errorCode information. --- ChangeLog | 3 +++ generic/tclNamesp.c | 6 ++++++ 2 files changed, 9 insertions(+) diff --git a/ChangeLog b/ChangeLog index 051880e..cb9f5c3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,8 @@ 2011-03-26 Donal K. Fellows + * generic/tclNamesp.c (Tcl_Export, Tcl_Import, DoImport): More + generation of errorCode information. + * generic/tclCompExpr.c, generic/tclCompile.c, generic/tclExecute.c: * generic/tclListObj.c, generic/tclNamesp.c, generic/tclObj.c: * generic/tclStringObj.c, generic/tclUtil.c: Reduce the number of diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 62ead7d..3a08221 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1335,6 +1335,7 @@ Tcl_Export( if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendResult(interp, "invalid export pattern \"", pattern, "\": pattern can't specify a namespace", NULL); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); return TCL_ERROR; } @@ -1539,6 +1540,7 @@ Tcl_Import( if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, @@ -1556,10 +1558,12 @@ Tcl_Import( Tcl_AppendResult(interp, "no namespace specified in import pattern \"", pattern, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); } else { Tcl_AppendResult(interp, "import pattern \"", pattern, "\" tries to import from namespace \"", importNsPtr->name, "\" into itself", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); } return TCL_ERROR; } @@ -1681,6 +1685,7 @@ DoImport( "\" would create a loop containing command \"", Tcl_DStringValue(&ds), "\"", NULL); Tcl_DStringFree(&ds); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } @@ -1720,6 +1725,7 @@ DoImport( } Tcl_AppendResult(interp, "can't import command \"", cmdName, "\": already exists", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } return TCL_OK; -- cgit v0.12 From ebe7cfc96d8d03998cc3df2030e3d56733082640 Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 27 Mar 2011 22:43:42 +0000 Subject: * generic/tclBasic.c (TclNREvalObjEx): fix performance issue, notably apparent in tclbench's 'LIST lset foreach'. Many thanks to twylite for patiently researching the issue and explaining it to me: a missing Tcl_ResetObjResult that causes unwanted sharing of the current result Tcl_Obj. --- ChangeLog | 8 ++++++++ generic/tclBasic.c | 3 +++ 2 files changed, 11 insertions(+) diff --git a/ChangeLog b/ChangeLog index cb9f5c3..23b91b7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2011-03-27 Miguel Sofer + + * generic/tclBasic.c (TclNREvalObjEx): fix performance issue, + notably apparent in tclbench's "LIST lset foreach". Many thanks to + twylite for patiently researching the issue and explaining it to + me: a missing Tcl_ResetObjResult that causes unwanted sharing of + the current result Tcl_Obj. + 2011-03-26 Donal K. Fellows * generic/tclNamesp.c (Tcl_Export, Tcl_Import, DoImport): More diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5f2b301..b34209b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6018,6 +6018,9 @@ TclNREvalObjEx( * iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ + if (TclInterpReady(interp) != TCL_OK) { + return TCL_ERROR; + } if (flags & TCL_EVAL_GLOBAL) { savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; -- cgit v0.12 From 54e58f9d2df63783abd9492926ed2cd4e4c6393a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Mar 2011 07:54:04 +0000 Subject: gcc warning: unused variable "key" --- generic/tclHash.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclHash.c b/generic/tclHash.c index 53d9919..b5baf22 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -1191,8 +1191,6 @@ RebuildTable(tablePtr) for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { *oldChainPtr = hPtr->nextPtr; - key = (VOID *) Tcl_GetHashKey (tablePtr, hPtr); - #if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { @@ -1203,6 +1201,7 @@ RebuildTable(tablePtr) hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; #else + key = (VOID *) Tcl_GetHashKey (tablePtr, hPtr); if (typePtr->hashKeyProc) { unsigned int hash; hash = typePtr->hashKeyProc (tablePtr, (VOID *) key); -- cgit v0.12 From aff97042289b6c2c5fd35cb8413deca7054ab0a7 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 28 Mar 2011 10:56:38 +0000 Subject: Use the error messages generated by the variable management code rather than creating our own in [regexp] and [regsub]. --- ChangeLog | 8 +++++++- generic/tclCmdMZ.c | 13 ++++--------- tests/regexp.test | 47 ++++++++++++++++++++++++++--------------------- tests/regexpComp.test | 35 ++++++++++++++++++++--------------- 4 files changed, 57 insertions(+), 46 deletions(-) diff --git a/ChangeLog b/ChangeLog index 23b91b7..703dc72 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,10 +1,16 @@ +2011-03-28 Donal K. Fellows + + * generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the + error messages generated by the variable management code rather than + creating our own. + 2011-03-27 Miguel Sofer * generic/tclBasic.c (TclNREvalObjEx): fix performance issue, notably apparent in tclbench's "LIST lset foreach". Many thanks to twylite for patiently researching the issue and explaining it to me: a missing Tcl_ResetObjResult that causes unwanted sharing of - the current result Tcl_Obj. + the current result Tcl_Obj. 2011-03-26 Donal K. Fellows diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 05f2e5d..e39ae06 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -383,12 +383,8 @@ Tcl_RegexpObjCmd( return TCL_ERROR; } } else { - Tcl_Obj *valuePtr; - - valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); - if (valuePtr == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[i]), "\"", NULL); + if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, + TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } } @@ -816,9 +812,8 @@ Tcl_RegsubObjCmd( Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { - if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[3]), "\"", NULL); + if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, + TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; } else { /* diff --git a/tests/regexp.test b/tests/regexp.test index 632a19d..7cafd1b 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -11,12 +11,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } -catch {unset foo} +unset -nocomplain foo testConstraint exec [llength [info commands exec]] @@ -196,7 +196,7 @@ set x $x$x$x$x$x$x$x$x$x$x$x$x test regexp-4.4 {case conversion in regexp} { list [regexp -nocase $x $x foo] $foo } "1 $x" -catch {unset x} +unset -nocomplain x test regexp-5.1 {exercise cache of compiled expressions} { regexp .*a b @@ -260,11 +260,12 @@ test regexp-6.6 {regexp errors} { test regexp-6.7 {regexp errors} { list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg } {0 0} -test regexp-6.8 {regexp errors} { - catch {unset f1} +test regexp-6.8 {regexp errors} -setup { + unset -nocomplain f1 +} -body { set f1 44 - list [catch {regexp abc abc f1(f2)} msg] $msg -} {1 {couldn't set variable "f1(f2)"}} + regexp abc abc f1(f2) +} -returnCodes error -result {can't set "f1(f2)": variable isn't array} test regexp-6.9 {regexp errors, -start bad int check} { list [catch {regexp -start bogus {^$} {}} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} @@ -456,11 +457,12 @@ test regexp-11.5 {regsub errors} { test regexp-11.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} -test regexp-11.7 {regsub errors} { - catch {unset f1} +test regexp-11.7 {regsub errors} -setup { + unset -nocomplain f1 +} -body { set f1 44 - list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg -} {1 {couldn't set variable "f1(f2)"}} + regsub -nocase aaa aaa xxx f1(f2) +} -returnCodes error -result {can't set "f1(f2)": variable isn't array} test regexp-11.8 {regsub errors, -start bad int check} { list [catch {regsub -start bogus pattern string rep var} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} @@ -527,23 +529,23 @@ test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -co } -result 1 test regexp-15.1 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start -10 {\d} 1abc2de3 x] $x } {1 1} test regexp-15.2 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 2 {\d} 1abc2de3 x] $x } {1 2} test regexp-15.3 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 4 {\d} 1abc2de3 x] $x } {1 2} test regexp-15.4 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 5 {\d} 1abc2de3 x] $x } {1 3} test regexp-15.5 {regexp -start, over end of string} { - catch {unset x} + unset -nocomplain x list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] } {0 0} test regexp-15.6 {regexp -start, loss of ^$ behavior} { @@ -556,11 +558,11 @@ test regexp-15.8 {regexp -start, double option} { regexp -start 0 -start 2 a abc } 0 test regexp-15.9 {regexp -start, end relative index} { - catch {unset x} + unset -nocomplain x list [regexp -start end {\d} 1abc2de3 x] [info exists x] } {0 0} test regexp-15.10 {regexp -start, end relative index} { - catch {unset x} + unset -nocomplain x list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x } {1 1 3} test regexp-15.11 {regexp -start, over end of string} { @@ -569,15 +571,15 @@ test regexp-15.11 {regexp -start, over end of string} { } {1 {}} test regexp-16.1 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x } {4 a1b/2c/3d/4e/5} test regexp-16.2 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start -25 {z} hello {/&} x] $x } {0 hello} test regexp-16.3 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 3 {z} hello {/&} x] $x } {0 hello} test regexp-16.4 {regsub -start, \A behavior} { @@ -1065,3 +1067,6 @@ test regexp-26.13 {regexp without -line option} { ::tcltest::cleanupTests return +# Local Variables: +# mode: tcl +# End: diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 6f0b688..94fb90e 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -29,7 +29,8 @@ proc evalInProc { script } { #return [list $status $result] } -catch {unset foo} +unset -nocomplain foo + test regexpComp-1.1 {basic regexp operation} { evalInProc { regexp ab*c abbbc @@ -258,7 +259,7 @@ test regexpComp-4.4 {case conversion in regexp} { list [regexp -nocase $::x $::x foo] $foo } } "1 $x" -catch {unset ::x} +unset -nocomplain ::x test regexpComp-5.1 {exercise cache of compiled expressions} { evalInProc { @@ -348,11 +349,11 @@ test regexpComp-6.7 {regexp errors} { } {0 0} test regexpComp-6.8 {regexp errors} { evalInProc { - catch {unset f1} + unset -nocomplain f1 set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } -} {1 {couldn't set variable "f1(f2)"}} +} {1 {can't set "f1(f2)": variable isn't array}} test regexpComp-6.9 {regexp errors, -start bad int check} { evalInProc { list [catch {regexp -start bogus {^$} {}} msg] $msg @@ -589,11 +590,11 @@ test regexpComp-11.6 {regsub errors} { } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} test regexpComp-11.7 {regsub errors} { evalInProc { - catch {unset f1} + unset -nocomplain f1 set f1 44 list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } -} {1 {couldn't set variable "f1(f2)"}} +} {1 {can't set "f1(f2)": variable isn't array}} test regexpComp-11.8 {regsub errors, -start bad int check} { evalInProc { list [catch {regsub -start bogus pattern string rep var} msg] $msg @@ -660,23 +661,23 @@ test regexpComp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} } -result 1 test regexpComp-15.1 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start -10 {\d} 1abc2de3 x] $x } {1 1} test regexpComp-15.2 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 2 {\d} 1abc2de3 x] $x } {1 2} test regexpComp-15.3 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 4 {\d} 1abc2de3 x] $x } {1 2} test regexpComp-15.4 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 5 {\d} 1abc2de3 x] $x } {1 3} test regexpComp-15.5 {regexp -start, over end of string} { - catch {unset x} + unset -nocomplain x list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] } {0 0} test regexpComp-15.6 {regexp -start, loss of ^$ behavior} { @@ -684,15 +685,15 @@ test regexpComp-15.6 {regexp -start, loss of ^$ behavior} { } {0} test regexpComp-16.1 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x } {4 a1b/2c/3d/4e/5} test regexpComp-16.2 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start -25 {z} hello {/&} x] $x } {0 hello} test regexpComp-16.3 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 3 {z} hello {/&} x] $x } {0 hello} test regexpComp-16.4 {regsub -start, \A behavior} { @@ -981,7 +982,11 @@ test regexpComp-24.11 {regexp command compiling tests} { regexp -- $re $text } } 1 - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From 8c516639abe302098e2202d7824bd9a23f8ca532 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Mar 2011 11:40:35 +0000 Subject: set default MODULE_SCOPE=extern, in case no other value is determined --- unix/configure | 22 ++++++++++++++++++++++ unix/tcl.m4 | 9 ++++++++- win/configure | 5 +++++ win/tcl.m4 | 1 + 4 files changed, 36 insertions(+), 1 deletion(-) diff --git a/unix/configure b/unix/configure index 9fbb864..8701f7e 100755 --- a/unix/configure +++ b/unix/configure @@ -6543,6 +6543,11 @@ echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6 CFLAGS="$CFLAGS -fvisibility=hidden" +cat >>confdefs.h <<\_ACEOF +#define MODULE_SCOPE extern +_ACEOF + + else @@ -8164,6 +8169,7 @@ cat >>confdefs.h <<\_ACEOF #define MODULE_SCOPE __private_extern__ _ACEOF + tcl_cv_cc_visibility_hidden=yes fi @@ -9036,6 +9042,22 @@ fi fi + if test "$tcl_cv_cc_visibility_hidden" != yes; then + + +cat >>confdefs.h <<\_ACEOF +#define MODULE_SCOPE extern +_ACEOF + + +cat >>confdefs.h <<\_ACEOF +#define NO_VIZ +_ACEOF + + +fi + + if test "$SHARED_LIB_SUFFIX" = ""; then SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 9e533f0..8c9eaf0 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1055,8 +1055,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ]) AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ CFLAGS="$CFLAGS -fvisibility=hidden" + AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden]) ], [ - AC_DEFINE(NO_VIZ, [], [No visibility attribute]) hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" AC_TRY_LINK([ extern __attribute__((__visibility__("hidden"))) void f(void); @@ -1663,6 +1663,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ AC_DEFINE(MODULE_SCOPE, [__private_extern__], [Compiler support for module scope symbols]) + tcl_cv_cc_visibility_hidden=yes ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" @@ -2061,6 +2062,12 @@ dnl # preprocessing tests use only CPPFLAGS. *) SHLIB_CFLAGS="-fPIC" ;; esac]) + AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ + AC_DEFINE(MODULE_SCOPE, [extern], + [No Compiler support for module scope symbols]) + AC_DEFINE(NO_VIZ, [], [No visibility attribute]) + ]) + AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [ SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}']) AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [ diff --git a/win/configure b/win/configure index e505fb2..d1d50e2 100755 --- a/win/configure +++ b/win/configure @@ -3932,6 +3932,11 @@ echo "${ECHO_T}$CELIB_DIR" >&6 # Set some defaults (may get changed below) EXTRA_CFLAGS="" +cat >>confdefs.h <<\_ACEOF +#define MODULE_SCOPE extern +_ACEOF + + # Extract the first word of "cygpath", so it can be a program name with args. set dummy cygpath; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 diff --git a/win/tcl.m4 b/win/tcl.m4 index 51498d6..6e3f3f9 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -402,6 +402,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # Set some defaults (may get changed below) EXTRA_CFLAGS="" + AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden]) AC_CHECK_PROG(CYGPATH, cygpath, cygpath -w, echo) -- cgit v0.12 From 5b43ec40f8e8d1787c1d12eec18205bfbf1fef1e Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 28 Mar 2011 12:15:07 +0000 Subject: Corrected odd comment --- generic/tclVar.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index a4b8a69..28151c0 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -5481,7 +5481,7 @@ DeleteArray( /* *---------------------------------------------------------------------- * - * TclTclObjVarErrMsg -- + * TclObjVarErrMsg -- * * Generate a reasonable error message describing why a variable * operation failed. -- cgit v0.12 From ce1706f3395619dee86a51d89a76c9537e4d8fe3 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 29 Mar 2011 15:06:26 +0000 Subject: More generation of errorCode information, notably when lists are mis-parsed. --- ChangeLog | 4 +++ generic/tclCmdMZ.c | 42 ++++++++++++++++++++++ generic/tclConfig.c | 7 +++- generic/tclUtil.c | 101 ++++++++++++++++++++++++++++------------------------ 4 files changed, 107 insertions(+), 47 deletions(-) diff --git a/ChangeLog b/ChangeLog index 703dc72..8e81f98 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,9 @@ 2011-03-28 Donal K. Fellows + * generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More + generation of errorCode information, notably when lists are + mis-parsed. + * generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the error messages generated by the variable management code rather than creating our own. diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index e39ae06..61de8de 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1794,6 +1794,8 @@ StringMapCmd( } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } } @@ -1856,6 +1858,8 @@ StringMapCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("char map list unbalanced", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", + "UNBALANCED", NULL); return TCL_ERROR; } } @@ -2057,6 +2061,8 @@ StringMatchCmd( } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } } @@ -2189,6 +2195,7 @@ StringReptCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "result exceeds max size for a Tcl value (%d bytes)", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } length2 = length1 * count; @@ -2209,6 +2216,7 @@ StringReptCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow, out of memory allocating %u bytes", length2 + 1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } for (index = 0; index < count; index++) { @@ -2514,6 +2522,8 @@ StringEqualCmd( } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } } @@ -2661,6 +2671,8 @@ StringCmpCmd( } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } } @@ -3558,6 +3570,8 @@ TclNRSwitchObjCmd( Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), "\": ", options[mode], " option already found", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "DOUBLEOPT", NULL); return TCL_ERROR; } foundmode = 1; @@ -3574,6 +3588,8 @@ TclNRSwitchObjCmd( if (i >= objc-2) { Tcl_AppendResult(interp, "missing variable name argument to ", "-indexvar", " option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } indexVarObj = objv[i]; @@ -3584,6 +3600,8 @@ TclNRSwitchObjCmd( if (i >= objc-2) { Tcl_AppendResult(interp, "missing variable name argument to ", "-matchvar", " option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } matchVarObj = objv[i]; @@ -3601,11 +3619,15 @@ TclNRSwitchObjCmd( if (indexVarObj != NULL && mode != OPT_REGEXP) { Tcl_AppendResult(interp, "-indexvar option requires -regexp option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { Tcl_AppendResult(interp, "-matchvar option requires -regexp option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } @@ -3653,6 +3675,8 @@ TclNRSwitchObjCmd( if (objc % 2) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + NULL); /* * Check if this can be due to a badly placed comment in the switch @@ -3669,6 +3693,8 @@ TclNRSwitchObjCmd( "comment incorrectly placed outside of a " "switch body - see the \"switch\" " "documentation", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "BADARM", "COMMENT?", NULL); break; } } @@ -3686,6 +3712,8 @@ TclNRSwitchObjCmd( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "no body specified for pattern \"", TclGetString(objv[objc-2]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + "FALLTHROUGH", NULL); return TCL_ERROR; } @@ -4006,6 +4034,8 @@ Tcl_ThrowObjCmd( return TCL_ERROR; } else if (len < 1) { Tcl_AppendResult(interp, "type must be non-empty list", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION", + NULL); return TCL_ERROR; } @@ -4189,12 +4219,16 @@ TclNRTryObjCmd( if (i < objc-2) { Tcl_AppendResult(interp, "finally clause must be last", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "NONTERMINAL", NULL); return TCL_ERROR; } else if (i == objc-1) { Tcl_AppendResult(interp, "wrong # args to finally clause: ", "must be \"", TclGetString(objv[0]), " ... finally script\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "ARGUMENT", NULL); return TCL_ERROR; } finallyObj = objv[++i]; @@ -4206,6 +4240,8 @@ TclNRTryObjCmd( "must be \"", TclGetString(objv[0]), " ... on code variableList script\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", + "ARGUMENT", NULL); return TCL_ERROR; } if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) { @@ -4221,6 +4257,8 @@ TclNRTryObjCmd( "must be \"... trap pattern variableList script\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "ARGUMENT", NULL); return TCL_ERROR; } code = 1; @@ -4229,6 +4267,8 @@ TclNRTryObjCmd( "bad prefix '%s': must be a list", Tcl_GetString(objv[i+1]))); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "EXNFORMAT", NULL); return TCL_ERROR; } info[2] = objv[i+1]; @@ -4260,6 +4300,8 @@ TclNRTryObjCmd( "last non-finally clause must not have a body of \"-\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", + NULL); return TCL_ERROR; } if (!haveHandlers) { diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 8d42e21..3ad5dfd 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -237,6 +237,8 @@ QueryConfigObjCmd( */ Tcl_SetResult(interp, "package not known", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", + Tcl_GetString(pkgName), NULL); return TCL_ERROR; } @@ -247,9 +249,11 @@ QueryConfigObjCmd( return TCL_ERROR; } - if (Tcl_DictObjGet(interp, pkgDict, objv [2], &val) != TCL_OK + if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK || val == NULL) { Tcl_SetResult(interp, "key not known", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", + Tcl_GetString(objv[2]), NULL); return TCL_ERROR; } @@ -268,6 +272,7 @@ QueryConfigObjCmd( if (!listPtr) { Tcl_SetResult(interp, "insufficient memory to create list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 69bd4d2..5e1efde 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -221,6 +221,8 @@ TclFindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in braces followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + NULL); } return TCL_ERROR; } @@ -280,6 +282,8 @@ TclFindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in quotes followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + NULL); } return TCL_ERROR; } @@ -297,12 +301,16 @@ TclFindElement( if (interp != NULL) { Tcl_SetResult(interp, "unmatched open brace in list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", + NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open quote in list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", + NULL); } return TCL_ERROR; } @@ -451,9 +459,6 @@ Tcl_SplitList( &elSize, &brace); length -= (list - prevList); if (result != TCL_OK) { - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", NULL); - } ckfree(argv); return result; } @@ -2119,10 +2124,9 @@ Tcl_PrintDouble( char *p, c; int exponent; int signum; - char* digits; - char* end; - - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); + char *digits; + char *end; + int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); /* * Handle NaN. @@ -2156,26 +2160,26 @@ Tcl_PrintDouble( if (*precisionPtr == 0) { digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, - &exponent, &signum, &end); + &exponent, &signum, &end); } else { /* * There are at least two possible interpretations for tcl_precision. * * The first is, "choose the decimal representation having - * $tcl_precision digits of significance that is nearest to the - * given number, breaking ties by rounding to even, and then - * trimming trailing zeros." This gives the greatest possible - * precision in the decimal string, but offers the anomaly that - * [expr 0.1] will be "0.10000000000000001". + * $tcl_precision digits of significance that is nearest to the given + * number, breaking ties by rounding to even, and then trimming + * trailing zeros." This gives the greatest possible precision in the + * decimal string, but offers the anomaly that [expr 0.1] will be + * "0.10000000000000001". * - * The second is "choose the decimal representation having at - * most $tcl_precision digits of significance that is nearest - * to the given number. If no such representation converts - * exactly to the given number, choose the one that is closest, - * breaking ties by rounding to even. If more than one such - * representation converts exactly to the given number, choose - * the shortest, breaking ties in favour of the nearest, breaking - * remaining ties in favour of the one ending in an even digit." + * The second is "choose the decimal representation having at most + * $tcl_precision digits of significance that is nearest to the given + * number. If no such representation converts exactly to the given + * number, choose the one that is closest, breaking ties by rounding + * to even. If more than one such representation converts exactly to + * the given number, choose the shortest, breaking ties in favour of + * the nearest, breaking remaining ties in favour of the one ending in + * an even digit." * * Tcl 8.4 implements the first of these, which gives rise to * anomalies in formatting: @@ -2188,13 +2192,13 @@ Tcl_PrintDouble( * 9.9999999999999995e-08 * * For human readability, it appears better to choose the second rule, - * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we - * prefer the first (the recommended zero value for tcl_precision - * avoids the problem entirely). + * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer + * the first (the recommended zero value for tcl_precision avoids the + * problem entirely). * - * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the - * method that allows floating point values to be shortened if - * it can be done without loss of precision. + * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method + * that allows floating point values to be shortened if it can be done + * without loss of precision. */ digits = TclDoubleDigits(value, *precisionPtr, @@ -2219,10 +2223,12 @@ Tcl_PrintDouble( c = *++p; } } + /* * Tcl 8.4 appears to format with at least a two-digit exponent; * preserve that behaviour when tcl_precision != 0 */ + if (*precisionPtr == 0) { sprintf(dst, "e%+d", exponent); } else { @@ -2410,6 +2416,7 @@ TclNeedSpace( * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ + return 1; } switch (*end) { @@ -2434,19 +2441,19 @@ TclNeedSpace( * This procedure formats an integer into a sequence of decimal digit * characters in a buffer. If the integer is negative, a minus sign is * inserted at the start of the buffer. A null character is inserted at - * the end of the formatted characters. It is the caller's - * responsibility to ensure that enough storage is available. This - * procedure has the effect of sprintf(buffer, "%ld", n) but is faster - * as proven in benchmarks. This is key to UpdateStringOfInt, which - * is a common path for a lot of code (e.g. int-indexed arrays). + * the end of the formatted characters. It is the caller's responsibility + * to ensure that enough storage is available. This procedure has the + * effect of sprintf(buffer, "%ld", n) but is faster as proven in + * benchmarks. This is key to UpdateStringOfInt, which is a common path + * for a lot of code (e.g. int-indexed arrays). * * Results: * An integer representing the number of characters formatted, not * including the terminating \0. * * Side effects: - * The formatted characters are written into the storage pointer to - * by the "buffer" argument. + * The formatted characters are written into the storage pointer to by + * the "buffer" argument. * *---------------------------------------------------------------------- */ @@ -2733,7 +2740,7 @@ SetEndOffsetFromAny( */ if (isspace(UCHAR(bytes[4]))) { - return TCL_ERROR; + goto badIndexFormat; } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { return TCL_ERROR; @@ -2746,6 +2753,7 @@ SetEndOffsetFromAny( * Conversion failed. Report the error. */ + badIndexFormat: if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, @@ -2853,7 +2861,8 @@ ClearHash( for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(objPtr); Tcl_DeleteHashEntry(hPtr); } @@ -2910,7 +2919,7 @@ static void FreeThreadHash( ClientData clientData) { - Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; + Tcl_HashTable *tablePtr = clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); @@ -2996,8 +3005,7 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, - INT2PTR(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -3273,9 +3281,10 @@ TclReToGlob( if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) { /* - * At most, the glob pattern has length 2*reStrLen + 2 to - * backslash escape every character and have * at each end. + * At most, the glob pattern has length 2*reStrLen + 2 to backslash + * escape every character and have * at each end. */ + Tcl_DStringSetLength(dsPtr, reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); *dsStr++ = '*'; @@ -3299,8 +3308,8 @@ TclReToGlob( } /* - * At most, the glob pattern has length reStrLen + 2 to account - * for possible * at each end. + * At most, the glob pattern has length reStrLen + 2 to account for + * possible * at each end. */ Tcl_DStringSetLength(dsPtr, reStrLen + 2); @@ -3310,9 +3319,8 @@ TclReToGlob( * Check for anchored REs (ie ^foo$), so we can use string equal if * possible. Do not alter the start of str so we can free it correctly. * - * Keep track of the last char being an unescaped star to prevent - * multiple instances. Simpler than checking that the last star - * may be escaped. + * Keep track of the last char being an unescaped star to prevent multiple + * instances. Simpler than checking that the last star may be escaped. */ msg = NULL; @@ -3420,6 +3428,7 @@ TclReToGlob( * Heuristic: if >1 non-anchoring *, the risk is large that glob * matching is slower than the RE engine, so report invalid. */ + msg = "excessive recursive glob backtrack potential"; goto invalidGlob; } -- cgit v0.12 From 6266f2e3593c1f443d49334bad71f9a5dde9a4f6 Mon Sep 17 00:00:00 2001 From: andreask Date: Wed, 30 Mar 2011 22:29:19 +0000 Subject: Fixed execute permission for unix/ldAix on this branch. core-8-4-branch and trunk are ok, so a merge is not required. --- tools/configure | 0 unix/ldAix | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) mode change 100755 => 100644 tools/configure mode change 100644 => 100755 unix/ldAix diff --git a/tools/configure b/tools/configure old mode 100755 new mode 100644 diff --git a/unix/ldAix b/unix/ldAix old mode 100644 new mode 100755 index cf37d40..51b2995 --- a/unix/ldAix +++ b/unix/ldAix @@ -1,5 +1,5 @@ #!/bin/sh -# +# # ldAix ldCmd ldArg ldArg ... # # This shell script provides a wrapper for ld under AIX in order to -- cgit v0.12 From 86d9abcd45aaf8619a159ae299d8df3fd30f2acf Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 31 Mar 2011 10:04:07 +0000 Subject: TclClockOldscanObjCmd: More generation of errorCode information. --- ChangeLog | 5 +++++ generic/tclDate.c | 8 ++++++++ generic/tclGetDate.y | 8 ++++++++ generic/tclThreadAlloc.c | 0 4 files changed, 21 insertions(+) mode change 100755 => 100644 generic/tclThreadAlloc.c diff --git a/ChangeLog b/ChangeLog index 8e81f98..e3d93dd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-03-31 Donal K. Fellows + + * generic/tclGetDate.y, generic/tclDate.c (TclClockOldscanObjCmd): + More generation of errorCode information. + 2011-03-28 Donal K. Fellows * generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More diff --git a/generic/tclDate.c b/generic/tclDate.c index 8aebbf3..14bac51 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2800,10 +2800,12 @@ TclClockOldscanObjCmd( if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " @@ -2811,6 +2813,7 @@ TclClockOldscanObjCmd( "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); @@ -2818,26 +2821,31 @@ TclClockOldscanObjCmd( if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 720b71c..da4c3fd 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -1011,10 +1011,12 @@ TclClockOldscanObjCmd( if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " @@ -1022,6 +1024,7 @@ TclClockOldscanObjCmd( "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); @@ -1029,26 +1032,31 @@ TclClockOldscanObjCmd( if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c old mode 100755 new mode 100644 -- cgit v0.12 From c8eb649431a107df0b9828649d96894768c00591 Mon Sep 17 00:00:00 2001 From: max Date: Fri, 1 Apr 2011 09:29:24 +0000 Subject: Implement TIP#131 --- ChangeLog | 4 ++++ library/init.tcl | 15 +++++++++++++++ 2 files changed, 19 insertions(+) diff --git a/ChangeLog b/ChangeLog index e3d93dd..86ef9e4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2011-04-01 Reinhard Max + + * library/init.tcl: TIP#131 implementation. + 2011-03-31 Donal K. Fellows * generic/tclGetDate.y, generic/tclDate.c (TclClockOldscanObjCmd): diff --git a/library/init.tcl b/library/init.tcl index 33b6b33..e6e69c3 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -821,3 +821,18 @@ proc tcl::CopyDirectory {action src dest} { } return } + +# TIP 131 +proc tcl::rmmadwiw {} { + set magic { + 42 83 fe f6 ff f8 f1 e5 c6 f9 eb fd ff fb f1 e5 cc f5 ec f5 e3 fd fe + ff f5 fa f3 e1 c7 f9 f2 fd ff f9 fe f9 ed f4 fa f6 e6 f9 f2 e6 fd f9 + ff f9 f6 e6 fa fd ff fc fb fc f9 f1 ed + } + foreach mystic [lassign $magic tragic] { + set comic [expr (0x$mystic ^ 0x$tragic) - 255 + 0x$tragic] + append logic [format %x $comic] + set tragic $mystic + } + binary format H* $logic +} -- cgit v0.12 From 4502b1fa0696dd647f8a38b72b8f689433bf98cd Mon Sep 17 00:00:00 2001 From: max Date: Fri, 1 Apr 2011 10:48:21 +0000 Subject: mathematical version of TIP#131 --- library/init.tcl | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/library/init.tcl b/library/init.tcl index e6e69c3..d85fe2a 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -836,3 +836,14 @@ proc tcl::rmmadwiw {} { } binary format H* $logic } + +proc tcl::mathfunc::rmmadwiw {} { + set age [expr {9*6}] + set mind "" + while {$age} { + lappend mind [expr {$age%13}] + set age [expr {$age/13}] + } + set matter [lreverse $mind] + return [join $matter ""] +} -- cgit v0.12 From f4b7658650c49deb8518bb22558332a16264cdf6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 2 Apr 2011 12:17:32 +0000 Subject: More generation of errorCode information (default [bgerror] and [glob]). --- ChangeLog | 5 +++++ generic/tclEvent.c | 2 ++ generic/tclFileName.c | 17 +++++++++++++++++ 3 files changed, 24 insertions(+) diff --git a/ChangeLog b/ChangeLog index 86ef9e4..f0d5bcc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-04-02 Donal K. Fellows + + * generic/tclEvent.c, generic/tclFileName.c: More generation of + errorCode information (default [bgerror] and [glob]). + 2011-04-01 Reinhard Max * library/init.tcl: TIP#131 implementation. diff --git a/generic/tclEvent.c b/generic/tclEvent.c index a8bab0b..6816487 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -333,6 +333,7 @@ TclDefaultBgErrorHandlerObjCmd( if (valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-level\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) { @@ -345,6 +346,7 @@ TclDefaultBgErrorHandlerObjCmd( if (valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-code\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) { diff --git a/generic/tclFileName.c b/generic/tclFileName.c index d53c271..05ecb04 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1258,11 +1258,14 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-directory\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-directory\" cannot be used with \"-path\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_DIR; @@ -1280,11 +1283,14 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-path\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-path\" cannot be used with \"-directory\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_GENERAL; @@ -1295,6 +1301,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-types\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } typePtr = objv[i+1]; @@ -1314,6 +1321,8 @@ Tcl_GlobObjCmd( Tcl_AppendResult(interp, "\"-tails\" must be used with either " "\"-directory\" or \"-path\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } @@ -1523,6 +1532,7 @@ Tcl_GlobObjCmd( Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1); Tcl_AppendObjToObj(resultPtr, look); Tcl_SetObjResult(interp, resultPtr); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); result = TCL_ERROR; join = 0; goto endOfGlob; @@ -1532,6 +1542,7 @@ Tcl_GlobObjCmd( "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); result = TCL_ERROR; + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); join = 0; goto endOfGlob; } @@ -1620,6 +1631,8 @@ Tcl_GlobObjCmd( } } Tcl_AppendResult(interp, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", + NULL); result = TCL_ERROR; } } @@ -2250,11 +2263,15 @@ DoGlob( } Tcl_SetResult(interp, "unmatched open-brace in file name", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", + NULL); return TCL_ERROR; } else if (*p == '}') { Tcl_SetResult(interp, "unmatched close-brace in file name", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", + NULL); return TCL_ERROR; } } -- cgit v0.12 From d2275aefb3bc8e96e7ae22e4609ba2c7604f86fe Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 2 Apr 2011 17:22:01 +0000 Subject: More generation of errorCodes ([interp], [lset], [load], [unload]). --- ChangeLog | 3 + generic/tclInterp.c | 161 +++++++++++++++++++++++++-------------------------- generic/tclListObj.c | 6 ++ generic/tclLoad.c | 36 +++++++++++- 4 files changed, 122 insertions(+), 84 deletions(-) diff --git a/ChangeLog b/ChangeLog index f0d5bcc..3179b6e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,8 @@ 2011-04-02 Donal K. Fellows + * generic/tclInterp.c, generic/tclListObj.c, generic/tclLoad.c: + More generation of errorCodes ([interp], [lset], [load], [unload]). + * generic/tclEvent.c, generic/tclFileName.c: More generation of errorCode information (default [bgerror] and [glob]). diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 67761ed..a156a57 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -300,8 +300,8 @@ Tcl_Init( { if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (TCL_ERROR); - }; + return TCL_ERROR; + } } /* @@ -559,6 +559,7 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Interp *slaveInterp; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", @@ -588,7 +589,7 @@ Tcl_InterpObjCmd( } switch ((enum option) index) { case OPT_ALIAS: { - Tcl_Interp *slaveInterp, *masterInterp; + Tcl_Interp *masterInterp; if (objc < 4) { aliasArgs: @@ -622,18 +623,13 @@ Tcl_InterpObjCmd( } goto aliasArgs; } - case OPT_ALIASES: { - Tcl_Interp *slaveInterp; - + case OPT_ALIASES: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return AliasList(interp, slaveInterp); - } - case OPT_BGERROR: { - Tcl_Interp *slaveInterp; - + case OPT_BGERROR: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); return TCL_ERROR; @@ -643,10 +639,8 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_CANCEL: { int i, flags; - Tcl_Interp *slaveInterp; Tcl_Obj *resultObjPtr; static const char *const cancelOptions[] = { "-unwind", "--", NULL @@ -680,8 +674,7 @@ Tcl_InterpObjCmd( } } - endOfForLoop: - + endOfForLoop: if ((i + 2) < objc) { Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? ?--? ?path? ?result?"); @@ -689,35 +682,34 @@ Tcl_InterpObjCmd( } /* - * Did they specify a slave interp to cancel the script in - * progress in? If not, use the current interp. + * Did they specify a slave interp to cancel the script in progress + * in? If not, use the current interp. */ if (i < objc) { slaveInterp = GetInterp(interp, objv[i]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } i++; } else { slaveInterp = interp; } - if (slaveInterp != NULL) { - if (i < objc) { - resultObjPtr = objv[i]; - - /* - * Tcl_CancelEval removes this reference. - */ + if (i < objc) { + resultObjPtr = objv[i]; - Tcl_IncrRefCount(resultObjPtr); - i++; - } else { - resultObjPtr = NULL; - } + /* + * Tcl_CancelEval removes this reference. + */ - return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); + Tcl_IncrRefCount(resultObjPtr); + i++; } else { - return TCL_ERROR; + resultObjPtr = NULL; } + + return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); } case OPT_CREATE: { int i, last, safe; @@ -787,13 +779,11 @@ Tcl_InterpObjCmd( Tcl_SetObjResult(interp, slavePtr); return TCL_OK; } - case OPT_DEBUG: { - /* TIP #378 */ - Tcl_Interp *slaveInterp; - + case OPT_DEBUG: /* TIP #378 */ /* * Currently only -frame supported, otherwise ?-option ?value?? */ + if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); return TCL_ERROR; @@ -803,11 +793,9 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_DELETE: { int i; InterpInfo *iiPtr; - Tcl_Interp *slaveInterp; for (i = 2; i < objc; i++) { slaveInterp = GetInterp(interp, objv[i]); @@ -816,6 +804,8 @@ Tcl_InterpObjCmd( } else if (slaveInterp == interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot delete the current interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "DELETESELF", NULL); return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; @@ -824,9 +814,7 @@ Tcl_InterpObjCmd( } return TCL_OK; } - case OPT_EVAL: { - Tcl_Interp *slaveInterp; - + case OPT_EVAL: if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; @@ -836,12 +824,9 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_EXISTS: { - int exists; - Tcl_Interp *slaveInterp; + int exists = 1; - exists = 1; slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { if (objc > 3) { @@ -853,9 +838,7 @@ Tcl_InterpObjCmd( Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); return TCL_OK; } - case OPT_EXPOSE: { - Tcl_Interp *slaveInterp; - + case OPT_EXPOSE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); return TCL_ERROR; @@ -865,10 +848,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDE: { - Tcl_Interp *slaveInterp; /* A slave. */ - + case OPT_HIDE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); return TCL_ERROR; @@ -878,30 +858,22 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDDEN: { - Tcl_Interp *slaveInterp; /* A slave. */ - + case OPT_HIDDEN: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveHidden(interp, slaveInterp); - } - case OPT_ISSAFE: { - Tcl_Interp *slaveInterp; - + case OPT_ISSAFE: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); return TCL_OK; - } case OPT_INVOKEHID: { int i; const char *namespaceName; - Tcl_Interp *slaveInterp; static const char *const hiddenOptions[] = { "-global", "-namespace", "--", NULL }; @@ -944,7 +916,6 @@ Tcl_InterpObjCmd( objv + i); } case OPT_LIMIT: { - Tcl_Interp *slaveInterp; static const char *const limitTypes[] = { "commands", "time", NULL }; @@ -973,9 +944,7 @@ Tcl_InterpObjCmd( return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); } } - case OPT_MARKTRUSTED: { - Tcl_Interp *slaveInterp; - + case OPT_MARKTRUSTED: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; @@ -985,10 +954,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveMarkTrusted(interp, slaveInterp); - } - case OPT_RECLIMIT: { - Tcl_Interp *slaveInterp; - + case OPT_RECLIMIT: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); return TCL_ERROR; @@ -998,9 +964,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_SLAVES: { - Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_Obj *resultPtr; Tcl_HashEntry *hPtr; @@ -1024,8 +988,7 @@ Tcl_InterpObjCmd( } case OPT_TRANSFER: case OPT_SHARE: { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Interp *masterInterp; /* The master of the slave. */ Tcl_Channel chan; if (objc != 5) { @@ -1060,7 +1023,6 @@ Tcl_InterpObjCmd( return TCL_OK; } case OPT_TARGET: { - Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; @@ -1093,6 +1055,8 @@ Tcl_InterpObjCmd( Tcl_AppendResult(interp, "target interpreter for alias \"", aliasName, "\" in path \"", Tcl_GetString(objv[2]), "\" is not my descendant", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "TARGETSHROUDED", NULL); return TCL_ERROR; } return TCL_OK; @@ -1437,6 +1401,8 @@ TclPreventAliasLoop( Tcl_AppendResult(interp, "cannot define or rename alias \"", Tcl_GetCommandName(cmdInterp, cmd), "\": would create a loop", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "ALIASLOOP", NULL); return TCL_ERROR; } @@ -2292,6 +2258,8 @@ SlaveBgerror( || (length < 1)) { Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BGERRORFORMAT", NULL); return TCL_ERROR; } TclSetBgErrorHandler(slaveInterp, objv[0]); @@ -2728,8 +2696,8 @@ SlaveDebugCmd( Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME)); Tcl_SetObjResult(interp, resultPtr); } else { - if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, - "debug option", 0, &debugType) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option", + 0, &debugType) != TCL_OK) { return TCL_ERROR; } if (debugType == DEBUG_TYPE_FRAME) { @@ -2738,11 +2706,13 @@ SlaveDebugCmd( != TCL_OK) { return TCL_ERROR; } + /* - * Quietly ignore attempts to disable interp debugging. - * This is a one-way switch as frame debug info is maintained - * in a stack that must be consistent once turned on. + * Quietly ignore attempts to disable interp debugging. This + * is a one-way switch as frame debug info is maintained in a + * stack that must be consistent once turned on. */ + if (debugType) { iPtr->flags |= INTERP_DEBUG_FRAME; } @@ -2847,6 +2817,8 @@ SlaveExpose( Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot expose commands", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } @@ -2890,6 +2862,8 @@ SlaveRecursionLimit( if (Tcl_IsSafe(interp)) { Tcl_AppendResult(interp, "permission denied: " "safe interpreters cannot change recursion limit", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { @@ -2898,6 +2872,8 @@ SlaveRecursionLimit( if (limit <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "recursion limit must be > 0", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT", + NULL); return TCL_ERROR; } Tcl_SetRecursionLimit(slaveInterp, limit); @@ -2905,6 +2881,7 @@ SlaveRecursionLimit( if (interp == slaveInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); + Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); @@ -2946,6 +2923,8 @@ SlaveHide( Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot hide commands", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } @@ -3028,6 +3007,8 @@ SlaveInvokeHidden( Tcl_SetObjResult(interp, Tcl_NewStringObj( "not allowed to invoke hidden commands from safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } @@ -3082,6 +3063,8 @@ SlaveMarkTrusted( Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot mark trusted", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; @@ -3339,6 +3322,7 @@ Tcl_LimitCheck( } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "command count limit exceeded", NULL); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -3364,6 +3348,7 @@ Tcl_LimitCheck( } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "time limit exceeded", NULL); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -4429,8 +4414,7 @@ SlaveCommandLimitCmd( } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, limitLen = 0; @@ -4455,6 +4439,8 @@ SlaveCommandLimitCmd( if (gran < 1) { Tcl_AppendResult(interp, "granularity must be at " "least 1", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4470,6 +4456,8 @@ SlaveCommandLimitCmd( if (limit < 0) { Tcl_AppendResult(interp, "command limit value must be at " "least 0", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4617,8 +4605,7 @@ SlaveTimeLimitCmd( } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, milliLen = 0, secLen = 0; @@ -4647,6 +4634,8 @@ SlaveTimeLimitCmd( if (gran < 1) { Tcl_AppendResult(interp, "granularity must be at " "least 1", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4662,6 +4651,8 @@ SlaveTimeLimitCmd( if (tmp < 0) { Tcl_AppendResult(interp, "milliseconds must be at least 0", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } limitMoment.usec = ((long)tmp)*1000; @@ -4678,6 +4669,8 @@ SlaveTimeLimitCmd( if (tmp < 0) { Tcl_AppendResult(interp, "seconds must be at least 0", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } limitMoment.sec = tmp; @@ -4694,11 +4687,15 @@ SlaveTimeLimitCmd( if (secObj != NULL && secLen == 0 && milliLen > 0) { Tcl_AppendResult(interp, "may only set -milliseconds " "if -seconds is not also being reset", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADUSAGE", NULL); return TCL_ERROR; } if (milliLen == 0 && (secObj == NULL || secLen > 0)) { Tcl_AppendResult(interp, "may only reset -milliseconds " "if -seconds is also being reset", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADUSAGE", NULL); return TCL_ERROR; } } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index b27163d..9128333 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1339,6 +1339,8 @@ TclLsetFlat( /* ...the index points outside the sublist. */ Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", + NULL); break; } @@ -1511,6 +1513,8 @@ TclListObjSetElement( if (!length) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", + NULL); return TCL_ERROR; } result = SetListFromAny(interp, listPtr); @@ -1531,6 +1535,8 @@ TclListObjSetElement( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", + NULL); } return TCL_ERROR; } diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 371a437..707d6ec 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -160,6 +160,8 @@ Tcl_LoadObjCmd( Tcl_SetResult(interp, "must specify either file name or package name", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", + NULL); code = TCL_ERROR; goto done; } @@ -226,6 +228,8 @@ Tcl_LoadObjCmd( Tcl_AppendResult(interp, "file \"", fullFileName, "\" is already loaded for package \"", pkgPtr->packageName, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", + "SPLITPERSONALITY", NULL); code = TCL_ERROR; Tcl_MutexUnlock(&packageMutex); goto done; @@ -261,6 +265,8 @@ Tcl_LoadObjCmd( if (fullFileName[0] == 0) { Tcl_AppendResult(interp, "package \"", packageName, "\" isn't loaded statically", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", + NULL); code = TCL_ERROR; goto done; } @@ -312,6 +318,8 @@ Tcl_LoadObjCmd( Tcl_AppendResult(interp, "couldn't figure out package name for ", fullFileName, NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", + "WHATPACKAGE", NULL); code = TCL_ERROR; goto done; } @@ -407,11 +415,22 @@ Tcl_LoadObjCmd( Tcl_AppendResult(interp, "can't use package in a safe interpreter: no ", pkgPtr->packageName, "_SafeInit procedure", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", + NULL); code = TCL_ERROR; goto done; } code = pkgPtr->safeInitProc(target); } else { + if (pkgPtr->initProc == NULL) { + Tcl_AppendResult(interp, + "can't attach package to interpreter: no ", + pkgPtr->packageName, "_Init procedure", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", + NULL); + code = TCL_ERROR; + goto done; + } code = pkgPtr->initProc(target); } @@ -555,6 +574,8 @@ Tcl_UnloadObjCmd( Tcl_SetResult(interp, "must specify either file name or package name", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", + NULL); code = TCL_ERROR; goto done; } @@ -626,6 +647,8 @@ Tcl_UnloadObjCmd( Tcl_AppendResult(interp, "package \"", packageName, "\" is loaded statically and cannot be unloaded", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", + NULL); code = TCL_ERROR; goto done; } @@ -636,6 +659,8 @@ Tcl_UnloadObjCmd( Tcl_AppendResult(interp, "file \"", fullFileName, "\" has never been loaded", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", + NULL); code = TCL_ERROR; goto done; } @@ -663,6 +688,8 @@ Tcl_UnloadObjCmd( Tcl_AppendResult(interp, "file \"", fullFileName, "\" has never been loaded in this interpreter", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", + NULL); code = TCL_ERROR; goto done; } @@ -677,6 +704,8 @@ Tcl_UnloadObjCmd( if (pkgPtr->safeUnloadProc == NULL) { Tcl_AppendResult(interp, "file \"", fullFileName, "\" cannot be unloaded under a safe interpreter", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); code = TCL_ERROR; goto done; } @@ -685,6 +714,8 @@ Tcl_UnloadObjCmd( if (pkgPtr->unloadProc == NULL) { Tcl_AppendResult(interp, "file \"", fullFileName, "\" cannot be unloaded under a trusted interpreter", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); code = TCL_ERROR; goto done; } @@ -771,8 +802,7 @@ Tcl_UnloadObjCmd( */ if (pkgPtr->fileName[0] != '\0') { - - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&packageMutex); if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { /* * Remove this library from the loaded library cache. @@ -824,6 +854,8 @@ Tcl_UnloadObjCmd( #else Tcl_AppendResult(interp, "file \"", fullFileName, "\" cannot be unloaded: unloading disabled", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", + NULL); code = TCL_ERROR; #endif } -- cgit v0.12 From 2db0d44d63bad5e5d32e84a38b8a4756d7dab1d0 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 2 Apr 2011 21:55:39 +0000 Subject: Replaced another couple of 'double' declarations with 'volatile double' to work around misrounding issues in mingw-gcc 3.4.5. --- ChangeLog | 6 ++++++ generic/tclStrToD.c | 6 ++++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 168dc0b..f1ab8a4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2011-04-02 Kevin B. Kenny + + * generic/tclStrToD.c (QuickConversion): Replaced another couple + of 'double' declarations with 'volatile double' to work around + misrounding issues in mingw-gcc 3.4.5. + 2011-03-24 Donal K. Fellows * generic/tclFCmd.c (TclFileAttrsCmd): Ensure that any reference to diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index d5c6e9c..139b8f2 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -2668,7 +2668,7 @@ StrictQuickFormat(double d, /* Number to convert */ */ inline static char* -QuickConversion(double d, /* Number to format */ +QuickConversion(double e, /* Number to format */ int k, /* floor(log10(d)), approximately */ int k_check, /* 0 if k is exact, 1 if it may be too high */ int flags, /* Flags passed to dtoa: @@ -2686,11 +2686,13 @@ QuickConversion(double d, /* Number to format */ char* retval; /* Returned string */ char* end; /* Pointer to the terminal null byte in the * returned string */ + volatile double d; /* Workaround for a bug in mingw gcc 3.4.5 */ /* * Bring d into the range [1 .. 10) */ - ieps = AdjustRange(&d, k); + ieps = AdjustRange(&e, k); + d = e; /* * If the guessed value of k didn't get d into range, adjust it -- cgit v0.12 From 2205a28b9e00ec29977d2b21e2f2bda3b77aaaf4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 3 Apr 2011 06:05:13 +0000 Subject: More generation of error codes (namespace creation, path normalization, pipeline creation, package handling, procedures, [scan] formats) --- ChangeLog | 8 +++++++ generic/tclNamesp.c | 4 ++++ generic/tclObj.c | 2 ++ generic/tclPathObj.c | 6 +++++ generic/tclPipe.c | 18 ++++++++++++++ generic/tclPkg.c | 44 +++++++++++++++++++++++----------- generic/tclProc.c | 68 ++++++++++++++++++++++++++++++++++++++-------------- generic/tclResult.c | 15 +++++++----- generic/tclScan.c | 11 +++++++++ tests/ioCmd.test | 6 ++--- 10 files changed, 141 insertions(+), 41 deletions(-) diff --git a/ChangeLog b/ChangeLog index 23b3f1e..b734896 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2011-04-03 Donal K. Fellows + + * generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c: + * generic/tclPipe.c, generic/tclPkg.c, generic/tclProc.c: + * generic/tclScan.c: More generation of error codes (namespace + creation, path normalization, pipeline creation, package handling, + procedures, [scan] formats) + 2011-04-02 Kevin B. Kenny * generic/tclStrToD.c (QuickConversion): Replaced another couple diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 3a08221..45b9f6d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -690,6 +690,8 @@ Tcl_CreateNamespace( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't create namespace \"\": " "only global namespace can have empty name", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEGLOBAL", NULL); return NULL; } else { /* @@ -725,6 +727,8 @@ Tcl_CreateNamespace( ) { Tcl_AppendResult(interp, "can't create namespace \"", name, "\": already exists", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); return NULL; } } diff --git a/generic/tclObj.c b/generic/tclObj.c index 321ed67..630226f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2265,6 +2265,8 @@ Tcl_GetDoubleFromObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", + NULL); } return TCL_ERROR; } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 81007a2..01a297b 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1523,6 +1523,8 @@ TclFSMakePathFromNormalized( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't find object" "string representation", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", + NULL); } return TCL_ERROR; } @@ -2423,6 +2425,8 @@ SetFsPathFromAny( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't find HOME environment " "variable to expand path", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", + "HOMELESS", NULL); } return TCL_ERROR; } @@ -2440,6 +2444,8 @@ SetFsPathFromAny( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "user \"", name+1, "\" doesn't exist", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", + NULL); } Tcl_DStringFree(&temp); if (split != len) { diff --git a/generic/tclPipe.c b/generic/tclPipe.c index c24d136..5f59c38 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -109,6 +109,8 @@ FileForRedirect( Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan), "\" wasn't opened for ", ((writing) ? "writing" : "reading"), NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADCHAN", NULL); } return NULL; } @@ -151,6 +153,7 @@ FileForRedirect( badLastArg: Tcl_AppendResult(interp, "can't specify \"", arg, "\" as last word in command", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL); return NULL; } @@ -342,6 +345,8 @@ TclCleanupChildren( } else { Tcl_AppendResult(interp, "child wait status didn't make sense\n", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "ODDWAITRESULT", msg1, NULL); } } } @@ -539,6 +544,8 @@ TclCreatePipeline( if ((i == (lastBar + 1)) || (i == (argc - 1))) { Tcl_SetResult(interp, "illegal use of | or |& in command", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } } @@ -565,6 +572,8 @@ TclCreatePipeline( if (inputLiteral == NULL) { Tcl_AppendResult(interp, "can't specify \"", argv[i], "\" as last word in command", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } skip = 2; @@ -673,6 +682,8 @@ TclCreatePipeline( if (i != argc-1) { Tcl_AppendResult(interp, "must specify \"", argv[i], "\" as last word in command", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } errorFile = outputFile; @@ -713,6 +724,8 @@ TclCreatePipeline( Tcl_SetResult(interp, "illegal use of | or |& in command", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", + NULL); goto error; } @@ -1063,11 +1076,15 @@ Tcl_OpenCommandChannel( if ((flags & TCL_STDOUT) && (outPipe == NULL)) { Tcl_AppendResult(interp, "can't read output from command:" " standard output was redirected", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADREDIRECT", NULL); goto error; } if ((flags & TCL_STDIN) && (inPipe == NULL)) { Tcl_AppendResult(interp, "can't write input to command:" " standard input was redirected", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADREDIRECT", NULL); goto error; } } @@ -1078,6 +1095,7 @@ Tcl_OpenCommandChannel( if (channel == NULL) { Tcl_AppendResult(interp, "pipe for command could not be created", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL); goto error; } return channel; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 53be4af..67503cb 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -156,6 +156,7 @@ Tcl_PkgProvideEx( } Tcl_AppendResult(interp, "conflicting versions provided for package \"", name, "\": ", pkgPtr->version, ", then ", version, NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } @@ -286,6 +287,7 @@ Tcl_PkgRequireEx( Tcl_AppendResult(interp, "Cannot load package \"", name, "\" in standalone executable: This package is not " "compiled with stub support", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); return NULL; } @@ -376,6 +378,7 @@ PkgRequireCore( "attempt to provide ", name, " ", (char *) pkgPtr->clientData, " requires ", name, NULL); AddRequirementsToResult(interp, reqc, reqv); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return NULL; } @@ -422,7 +425,9 @@ PkgRequireCore( } } - /* We have found a version which is better than our max. */ + /* + * We have found a version which is better than our max. + */ if (reqc > 0) { /* Check satisfaction of requirements. */ @@ -493,6 +498,8 @@ PkgRequireCore( name, " ", versionToProvide, " failed: no version of package ", name, " provided", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); } else { char *pvi, *vi; @@ -515,6 +522,8 @@ PkgRequireCore( versionToProvide, " failed: package ", name, " ", pkgPtr->version, " provided instead", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); } } } @@ -525,6 +534,7 @@ PkgRequireCore( Tcl_AppendResult(interp, "attempt to provide package ", name, " ", versionToProvide, " failed: bad return code: ", TclGetString(codePtr), NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); TclDecrRefCount(codePtr); code = TCL_ERROR; } @@ -582,9 +592,11 @@ PkgRequireCore( if ((code != TCL_OK) && (code != TCL_ERROR)) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); + Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad return code: ", TclGetString(codePtr), NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); Tcl_DecrRefCount(codePtr); code = TCL_ERROR; } @@ -599,6 +611,7 @@ PkgRequireCore( if (pkgPtr->version == NULL) { Tcl_AppendResult(interp, "can't find package ", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); return NULL; } @@ -608,27 +621,28 @@ PkgRequireCore( * provided version meets the current requirements. */ - if (reqc == 0) { - satisfies = 1; - } else { + if (reqc != 0) { CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); - } - if (satisfies) { - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; - *ptr = pkgPtr->clientData; + if (!satisfies) { + Tcl_AppendResult(interp, "version conflict for package \"", name, + "\": have ", pkgPtr->version, ", need", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", + NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; } - return pkgPtr->version; } - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return NULL; + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; + + *ptr = pkgPtr->clientData; + } + return pkgPtr->version; } /* @@ -1328,6 +1342,7 @@ CheckVersionAndConvert( ckfree(ibuf); Tcl_AppendResult(interp, "expected version number but got \"", string, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); return TCL_ERROR; } @@ -1590,6 +1605,7 @@ CheckRequirement( Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); return TCL_ERROR; } diff --git a/generic/tclProc.c b/generic/tclProc.c index 6cd5bb2..9f4ba29 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -154,11 +154,13 @@ Tcl_ProcObjCmd( if (nsPtr == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, "\": unknown namespace", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if (procName == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, "\": bad procedure name", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) @@ -166,6 +168,7 @@ Tcl_ProcObjCmd( Tcl_AppendResult(interp, "can't create procedure \"", procName, "\" in non-global namespace with name starting with \":\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -490,6 +493,8 @@ TclCreateProc( "procedure \"%s\": arg list contains %d entries, " "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } localPtr = procPtr->firstLocalPtr; @@ -516,11 +521,15 @@ TclCreateProc( Tcl_AppendResult(interp, "too many fields in argument specifier \"", argArray[i], "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { ckfree(fieldValues); Tcl_AppendResult(interp, "argument with no name", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } @@ -547,12 +556,16 @@ TclCreateProc( Tcl_AppendResult(interp, "formal parameter \"", fieldValues[0], "\" is an array element", NULL); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { Tcl_AppendResult(interp, "formal parameter \"", fieldValues[0], "\" is not a simple name", NULL); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } p++; @@ -580,6 +593,8 @@ TclCreateProc( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } @@ -599,6 +614,8 @@ TclCreateProc( "default value inconsistent with precompiled body", procName, fieldValues[0])); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } } @@ -752,6 +769,7 @@ TclGetFrame( levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -884,7 +902,7 @@ TclObjGetFrame( levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -1863,6 +1881,7 @@ InterpProcNR2( Tcl_AppendResult(interp, "invoked \"", ((result == TCL_BREAK) ? "break" : "continue"), "\" outside of a loop", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; /* @@ -1980,6 +1999,8 @@ TclProcCompileProc( if ((Interp *) *codePtr->interpHandle != iPtr) { Tcl_AppendResult(interp, "a precompiled script jumped interps", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; @@ -2468,6 +2489,7 @@ SetLambdaFromAny( Tcl_AppendObjToObj(errPtr, objPtr); Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); Tcl_SetObjResult(interp, errPtr); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); return TCL_ERROR; } @@ -2893,26 +2915,28 @@ Tcl_DisassembleObjCmd( if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "procName"); return TCL_ERROR; - } else { - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" isn't a procedure", NULL); - return TCL_ERROR; - } + } - /* - * Compile (if uncompiled) and disassemble a procedure. - */ + procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + if (procPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), + "\" isn't a procedure", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; case DISAS_SCRIPT: /* * Compile and disassemble a script. @@ -2947,6 +2971,8 @@ Tcl_DisassembleObjCmd( if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), "\" is not a class", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, @@ -2980,12 +3006,16 @@ Tcl_DisassembleObjCmd( unknownMethod: Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[3]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[3]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { Tcl_AppendResult(interp, "body not available for this kind of method", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); return TCL_ERROR; } if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { @@ -3019,6 +3049,8 @@ Tcl_DisassembleObjCmd( if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "BYTECODE", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); diff --git a/generic/tclResult.c b/generic/tclResult.c index fad3b82..6a71ee2 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1487,9 +1487,10 @@ TclMergeReturnOptions( */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad -errorstack value: " - "expected a list but got \"", - TclGetString(valuePtr), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", NULL); + "expected a list but got \"", TclGetString(valuePtr), + "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", + NULL); goto error; } if (length % 2) { @@ -1497,9 +1498,11 @@ TclMergeReturnOptions( * Errorstack must always be an even-sized list */ Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "forbidden odd-sized list for -errorstack: \"", - TclGetString(valuePtr), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ODDSIZEDLIST_ERRORSTACK", NULL); + Tcl_AppendResult(interp, + "forbidden odd-sized list for -errorstack: \"", + TclGetString(valuePtr), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", + "ODDSIZEDLIST_ERRORSTACK", NULL); goto error; } } diff --git a/generic/tclScan.c b/generic/tclScan.c index c862be4..68b8d21 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -331,6 +331,7 @@ ValidateFormat( Tcl_SetResult(interp, "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL); goto error; } @@ -377,6 +378,7 @@ ValidateFormat( Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL); goto error; } /* @@ -390,6 +392,7 @@ ValidateFormat( Tcl_AppendResult(interp, "field size modifier may not be specified in %", buf, " conversion", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL); goto error; } /* @@ -408,6 +411,7 @@ ValidateFormat( if (flags & SCAN_BIG) { Tcl_SetResult(interp, "unsigned bignum scans are invalid", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); goto error; } break; @@ -444,11 +448,13 @@ ValidateFormat( badSet: Tcl_SetResult(interp, "unmatched [ in format string", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL); goto error; default: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_AppendResult(interp, "bad scan conversion character \"", buf, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); goto error; } if (!(flags & SCAN_SUPPRESS)) { @@ -495,6 +501,7 @@ ValidateFormat( Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL); goto error; } else if (!xpgSize && (nassign[i] == 0)) { /* @@ -505,6 +512,7 @@ ValidateFormat( Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL); goto error; } } @@ -516,10 +524,12 @@ ValidateFormat( if (gotXpg) { Tcl_SetResult(interp, "\"%n$\" argument index out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL); } else { Tcl_SetResult(interp, "different numbers of variable names and field specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL); } error: @@ -991,6 +1001,7 @@ Tcl_ScanObjCmd( continue; } result++; +#warning Why make your own error message? Why? if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", TclGetString(objv[i+3]), "\"", NULL); diff --git a/tests/ioCmd.test b/tests/ioCmd.test index c83d174..82f83db 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -386,13 +386,13 @@ test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { set f [open $path(test4) w] close $f list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode -} {1 {can't write input to command: standard input was redirected} NONE} +} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}} test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode -} {1 {can't read output from command: standard output was redirected} NONE} +} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode -} {1 {can't read output from command: standard output was redirected} NONE} +} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} test iocmd-11.4 {I/O to command pipelines} unixOrPc { list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}} -- cgit v0.12 From 25e4dca4916e5ae7be29bb21c40e59f3adb4b5ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Apr 2011 13:40:01 +0000 Subject: Better error-message in case of errors related to setting a variable --- ChangeLog | 11 +++++++++++ generic/tclCmdAH.c | 10 ++-------- generic/tclCmdIL.c | 22 ++++++++-------------- generic/tclDictObj.c | 20 ++++---------------- generic/tclScan.c | 8 ++++---- generic/tclTest.c | 4 +--- tests/error.test | 38 +++++++++++++++++++------------------- tests/info.test | 6 +++--- tests/scan.test | 14 +++++++------- 9 files changed, 59 insertions(+), 74 deletions(-) diff --git a/ChangeLog b/ChangeLog index b734896..63e4391 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2011-04-04 Jan Nijtmans + + * generic/tclCmdAH.c: Better error-message in case of errors + * generic/tclCmdIL.c: related to setting a variable. This fixes + * generic/tclDictObj.c: a warning: "Why make your own error + * generic/tclScan.c: message? Why?" + * generic/tclTest.c: + * test/error.test: + * test/info.test: + * test/scan.test: + 2011-04-03 Donal K. Fellows * generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c: diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 3edfa54..8b5f13d 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -345,10 +345,7 @@ CatchObjCmdCallback( if (objc >= 3) { if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, - Tcl_GetObjResult(interp), 0)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "couldn't save command result in variable", NULL); + Tcl_GetObjResult(interp), TCL_LEAVE_ERR_MSG)) { return TCL_ERROR; } } @@ -356,11 +353,8 @@ CatchObjCmdCallback( Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, - options, 0)) { + options, TCL_LEAVE_ERR_MSG)) { Tcl_DecrRefCount(options); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "couldn't save return options in variable", NULL); return TCL_ERROR; } } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b38ec9f..c42a54b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -966,7 +966,7 @@ InfoDefaultCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - const char *procName, *argName, *varName; + const char *procName, *argName; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *valueObjPtr; @@ -993,18 +993,18 @@ InfoDefaultCmd( && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - localPtr->defValuePtr, 0); + localPtr->defValuePtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { - goto defStoreError; + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - nullObjPtr, 0); + nullObjPtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { - goto defStoreError; + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } @@ -1016,12 +1016,6 @@ InfoDefaultCmd( "\" doesn't have an argument \"", argName, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); return TCL_ERROR; - - defStoreError: - varName = TclGetString(objv[3]); - Tcl_AppendResult(interp, "couldn't store default value in variable \"", - varName, "\"", NULL); - return TCL_ERROR; } /* @@ -1058,7 +1052,7 @@ InfoErrorStackCmd( Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - + target = interp; if (objc == 2) { target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); @@ -1069,7 +1063,7 @@ InfoErrorStackCmd( iPtr = (Interp *) target; Tcl_SetObjResult(interp, iPtr->errorStack); - + return TCL_OK; } @@ -1163,7 +1157,7 @@ InfoFrameCmd( CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; CmdFrame *runPtr = iPtr->cmdFramePtr; CmdFrame *lastPtr = NULL; - + topLevel += corPtr->caller.cmdFramePtr->level; while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) { lastPtr = runPtr; diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 3da91a3..508c2af 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2456,18 +2456,12 @@ DictForNRCmd( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); goto error; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { goto error; } @@ -2540,19 +2534,13 @@ DictForLoopCallback( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); result = TCL_ERROR; goto done; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; goto done; } diff --git a/generic/tclScan.c b/generic/tclScan.c index 68b8d21..06e66e4 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1001,10 +1001,10 @@ Tcl_ScanObjCmd( continue; } result++; -#warning Why make your own error message? Why? - if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[i+3]), "\"", NULL); + /* In case of multiple errors in setting variables, just report + * the first one. */ + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], + (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) { code = TCL_ERROR; } Tcl_DecrRefCount(objs[i]); diff --git a/generic/tclTest.c b/generic/tclTest.c index b757185..bac0c7f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3939,10 +3939,8 @@ TestregexpObjCmd( info.matches[ii].end - 1); } } - valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0); + valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - Tcl_GetString(varPtr), "\"", NULL); return TCL_ERROR; } } diff --git a/tests/error.test b/tests/error.test index c34ccb0..97bcc0a 100644 --- a/tests/error.test +++ b/tests/error.test @@ -138,7 +138,7 @@ test error-3.3 {errors in catch command} { catch {unset a} set a(0) 22 list [catch {catch {format 44} a} msg] $msg -} {1 {couldn't save command result in variable}} +} {1 {can't set "a": variable is array}} catch {unset a} # More tests related to errorInfo and errorCode @@ -417,7 +417,7 @@ test error-12.4 {try with result/opts variable assignment in on handler} { } {bar,FOO} test error-12.5 {try with result/opts variable assignment in on handler, vars remain in scope} { try { throw FOO bar } on error {res opts} { list d e f } - set r "$res,[dict get $opts -errorcode]" + set r "$res,[dict get $opts -errorcode]" } {bar,FOO} test error-12.6 {try result is propagated if no matching handler} { try { list a b c } on error {} { list d e f } @@ -459,7 +459,7 @@ test error-13.8 {try with multiple handlers and finally (ok)} { try list on error {} {} trap {} {} {} finally {} } {} test error-13.9 {last handler body can't be a fallthrough #1} -body { - try list on error {} {} on break {} - + try list on error {} {} on break {} - } -returnCodes error -result {last non-finally clause must not have a body of "-"} test error-13.10 {last handler body can't be a fallthrough #2} -body { try list on error {} {} on break {} - finally { list d e f } @@ -471,7 +471,7 @@ test error-14.1 {try with multiple handlers (only one matches) #1} { try { throw FOO bar } on ok {} { list a b c } trap FOO {} { list d e f } } {d e f} test error-14.2 {try with multiple handlers (only one matches) #2} { - try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c } + try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c } } {d e f} test error-14.3 {try with multiple handlers (only one matches) #3} { try { @@ -482,7 +482,7 @@ test error-14.3 {try with multiple handlers (only one matches) #3} { list d e f } on ok {} { list a b c - } + } } {d e f} test error-14.4 {try with multiple matching handlers (only the first in left-to-right order runs) #1} { try { throw FOO bar } on error {} { list a b c } trap FOO {} { list d e f } @@ -593,16 +593,16 @@ test error-16.6 {try with variable assignment and propagation #1} { catch { try { throw FOO bar } trap FOO {em} { throw BAR baz } } - set em + set em } {bar} test error-16.7 {try with variable assignment and propagation #2} { catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} test error-16.8 {exception chaining (try=ok, handler=error)} { - #FIXME is the intent of this test correct? + #FIXME is the intent of this test correct? catch { try { list a b c } on ok {em opts} { throw BAR baz } } tryem tryopts @@ -686,7 +686,7 @@ test error-17.11 {successful finally doesn't affect variable assignment or propa catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { list d e f } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} # try tests - propagation (exceptions in finally, exception chaining) @@ -707,11 +707,11 @@ test error-18.5 {exception in finally doesn't affect variable assignment} { catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { throw BAZ zing } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} test error-18.6 {exception chaining in finally (try=ok)} { catch { - list a b c + list a b c } em expopts catch { try { list a b c } finally { throw BAR foo } @@ -782,14 +782,14 @@ test error-19.1 {try with fallthrough body #1} { } {1} test error-19.2 {try with fallthrough body #2} { set RES {} - try { - throw FOO bar + try { + throw FOO bar } trap BAR {} { } trap FOO {} - trap {} {} { set RES foo } on error {} { set RES err - } + } set RES } {foo} test error-19.3 {try with cascade fallthrough} { @@ -805,22 +805,22 @@ test error-19.4 {multiple unrelated fallthroughs #1} { set RES {} try { throw FOO bar - } trap FOO {} - trap BAR {} { + } trap FOO {} - trap BAR {} { set RES foo } trap {} {} - on error {} { set RES err - } + } set RES } {foo} test error-19.5 {multiple unrelated fallthroughs #2} { set RES {} try { throw BAZ zing - } trap FOO {} - trap BAR {} { + } trap FOO {} - trap BAR {} { set RES foo } trap {} {} - on error {} { set RES err - } + } set RES } {err} proc addmsg msg { @@ -1054,7 +1054,7 @@ namespace delete ::tcl::test::error # cleanup catch {rename p ""} ::tcltest::cleanupTests -return +return # Local Variables: # mode: tcl diff --git a/tests/info.test b/tests/info.test index 9977054..3323281 100644 --- a/tests/info.test +++ b/tests/info.test @@ -215,14 +215,14 @@ test info-6.9 {info default option} -returnCodes error -setup { set a(0) 88 proc t1 {a b} {} info default t1 a a -} -returnCodes error -result {couldn't store default value in variable "a"} +} -returnCodes error -result {can't set "a": variable is array} test info-6.10 {info default option} -setup { catch {unset a} } -cleanup {unset a} -body { set a(0) 88 proc t1 {{a 18} b} {} info default t1 a a -} -returnCodes error -result {couldn't store default value in variable "a"} +} -returnCodes error -result {can't set "a": variable is array} test info-6.11 {info default option} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { @@ -1826,7 +1826,7 @@ test info-30.46 {TIP 280 for compiled [subst]} { } YES test info-30.47 {TIP 280 for compiled [subst]} { unset -nocomplain a - set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 + set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 subst {$a( [dict get [info frame 0] line])} ; # 1831 } YES diff --git a/tests/scan.test b/tests/scan.test index 6e1ccb0..84f22b4 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -328,7 +328,7 @@ test scan-4.60 {Tcl_ScanObjCmd, set errors} { $msg $x $y] unset z set result -} {1 {couldn't set variable "z"} abc ghi} +} {1 {can't set "z": variable is array} abc ghi} test scan-4.61 {Tcl_ScanObjCmd, set errors} { set x {} catch {unset y}; array set y {} @@ -338,7 +338,7 @@ test scan-4.61 {Tcl_ScanObjCmd, set errors} { unset y unset z set result -} {1 {couldn't set variable "z"couldn't set variable "y"} abc} +} {1 {can't set "z": variable is array} abc} # procedure that returns the range of integers @@ -545,27 +545,27 @@ test scan-8.12 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %d a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.13 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %c a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.14 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %s a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.15 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %f a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.16 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %f a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} catch {unset a} test scan-8.17 {error conditions} { list [catch {scan 44 %2c a} msg] $msg -- cgit v0.12 From 6965ff95a63177a766b1be29435d3cf3592f593b Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 4 Apr 2011 13:46:33 +0000 Subject: Minor tinkering with style. --- generic/tclScan.c | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/generic/tclScan.c b/generic/tclScan.c index 06e66e4..d21bfaf 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1001,8 +1001,12 @@ Tcl_ScanObjCmd( continue; } result++; - /* In case of multiple errors in setting variables, just report - * the first one. */ + + /* + * In case of multiple errors in setting variables, just report + * the first one. + */ + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) { code = TCL_ERROR; @@ -1050,7 +1054,7 @@ Tcl_ScanObjCmd( } return code; } - + /* * Local Variables: * mode: c -- cgit v0.12 From 875ed401f93f459fbac8cfd682d6e015b10f7ad3 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 4 Apr 2011 13:55:06 +0000 Subject: More generation of error codes ([format], [after], [trace], RE optimizer). --- ChangeLog | 6 +++ generic/tclBasic.c | 126 ++++++++++++++++++++++++------------------------- generic/tclStringObj.c | 22 ++++++++- generic/tclTimer.c | 34 +++++++------ generic/tclTrace.c | 8 ++++ generic/tclUtil.c | 11 ++++- 6 files changed, 125 insertions(+), 82 deletions(-) diff --git a/ChangeLog b/ChangeLog index 63e4391..4724598 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2011-04-04 Donal K. Fellows + + * generic/tclBasic.c, generic/tclStringObj.c, generic/tclTimer.c, + * generic/tclTrace.c, generic/tclUtil.c: More generation of error + codes ([format], [after], [trace], RE optimizer). + 2011-04-04 Jan Nijtmans * generic/tclCmdAH.c: Better error-message in case of errors diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b34209b..f00864f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2498,7 +2498,8 @@ TclRenameCommand( if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { Tcl_AppendResult(interp, "can't rename to \"", newName, "\": command already exists", NULL); - Tcl_SetErrorCode(interp, "TCL", "RENAME", "TARGET_EXISTS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", + "TARGET_EXISTS", NULL); result = TCL_ERROR; goto done; } @@ -3883,82 +3884,79 @@ Tcl_Canceled( register Interp *iPtr = (Interp *) interp; /* - * Has the current script in progress for this interpreter been - * canceled or is the stack being unwound due to the previous script - * cancellation? - */ + * Has the current script in progress for this interpreter been canceled + * or is the stack being unwound due to the previous script cancellation? + */ - if (TclCanceled(iPtr)) { - /* - * The CANCELED flag is a one-shot flag that is reset immediately - * upon being detected; however, if the TCL_CANCEL_UNWIND flag is - * set we will continue to report that the script in progress has - * been canceled thereby allowing the evaluation stack for the - * interp to be fully unwound. - */ + if (!TclCanceled(iPtr)) { + return TCL_OK; + } - iPtr->flags &= ~CANCELED; + /* + * The CANCELED flag is a one-shot flag that is reset immediately upon + * being detected; however, if the TCL_CANCEL_UNWIND flag is set we will + * continue to report that the script in progress has been canceled + * thereby allowing the evaluation stack for the interp to be fully + * unwound. + */ - /* - * The CANCELED flag was detected and reset; however, if the - * caller specified the TCL_CANCEL_UNWIND flag, we only return - * TCL_ERROR (indicating that the script in progress has been - * canceled) if the evaluation stack for the interp is being fully - * unwound. - */ + iPtr->flags &= ~CANCELED; - if (!(flags & TCL_CANCEL_UNWIND) - || (iPtr->flags & TCL_CANCEL_UNWIND)) { - /* - * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error - * in the interp's result; otherwise, we leave it alone. - */ + /* + * The CANCELED flag was detected and reset; however, if the caller + * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR + * (indicating that the script in progress has been canceled) if the + * evaluation stack for the interp is being fully unwound. + */ - if (flags & TCL_LEAVE_ERR_MSG) { - const char *id, *message = NULL; - int length; + if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) { + return TCL_OK; + } - /* - * Setup errorCode variables so that we can differentiate - * between being canceled and unwound. - */ + /* + * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the + * interp's result; otherwise, we leave it alone. + */ - if (iPtr->asyncCancelMsg != NULL) { - message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, - &length); - } else { - length = 0; - } + if (flags & TCL_LEAVE_ERR_MSG) { + const char *id, *message = NULL; + int length; - if (iPtr->flags & TCL_CANCEL_UNWIND) { - id = "IUNWIND"; - if (length == 0) { - message = "eval unwound"; - } - } else { - id = "ICANCEL"; - if (length == 0) { - message = "eval canceled"; - } - } + /* + * Setup errorCode variables so that we can differentiate between + * being canceled and unwound. + */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, message, NULL); - Tcl_SetErrorCode(interp, "TCL", id, message, NULL); - } + if (iPtr->asyncCancelMsg != NULL) { + message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); + } else { + length = 0; + } - /* - * Return TCL_ERROR to the caller (not necessarily just the - * Tcl core itself) that indicates further processing of the - * script or command in progress should halt gracefully and as - * soon as possible. - */ + if (iPtr->flags & TCL_CANCEL_UNWIND) { + id = "IUNWIND"; + if (length == 0) { + message = "eval unwound"; + } + } else { + id = "ICANCEL"; + if (length == 0) { + message = "eval canceled"; + } + } - return TCL_ERROR; - } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, message, NULL); + Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL); } - return TCL_OK; + /* + * Return TCL_ERROR to the caller (not necessarily just the Tcl core + * itself) that indicates further processing of the script or command in + * progress should halt gracefully and as soon as possible. + */ + + return TCL_ERROR; } /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index cf635bc..fe6d0af 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1609,7 +1609,6 @@ AppendUtfToUtfRep( objPtr->bytes[newLength] = 0; objPtr->length = newLength; } - /* *---------------------------------------------------------------------- @@ -1706,7 +1705,7 @@ Tcl_AppendFormatToObj( int objc, Tcl_Obj *const objv[]) { - const char *span = format, *msg; + const char *span = format, *msg, *errCode; int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0; int originalLength, limit; static const char *mixedXPG = @@ -1744,6 +1743,7 @@ Tcl_AppendFormatToObj( if (numBytes) { if (numBytes > limit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(appendObj, span, numBytes); @@ -1783,18 +1783,21 @@ Tcl_AppendFormatToObj( if (newXpg) { if (gotSequential) { msg = mixedXPG; + errCode = "MIXEDSPECTYPES"; goto errorMsg; } gotXpg = 1; } else { if (gotXpg) { msg = mixedXPG; + errCode = "MIXEDSPECTYPES"; goto errorMsg; } gotSequential = 1; } if ((objIndex < 0) || (objIndex >= objc)) { msg = badIndex[gotXpg]; + errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } @@ -1842,6 +1845,7 @@ Tcl_AppendFormatToObj( } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; + errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) { @@ -1857,6 +1861,7 @@ Tcl_AppendFormatToObj( } if (width > limit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } @@ -1877,6 +1882,7 @@ Tcl_AppendFormatToObj( } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; + errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH"; goto errorMsg; } if (TclGetIntFromObj(interp, objv[objIndex], &precision) @@ -1934,6 +1940,7 @@ Tcl_AppendFormatToObj( switch (ch) { case '\0': msg = "format string ended in middle of field specifier"; + errCode = "INCOMPLETE"; goto errorMsg; case 's': if (gotPrecision) { @@ -1963,6 +1970,7 @@ Tcl_AppendFormatToObj( case 'u': if (useBig) { msg = "unsigned bignum format is invalid"; + errCode = "BADUNSIGNED"; goto errorMsg; } case 'd': @@ -2110,6 +2118,7 @@ Tcl_AppendFormatToObj( } if (toAppend > segmentLimit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(segment, bytes, toAppend); @@ -2165,6 +2174,7 @@ Tcl_AppendFormatToObj( } if (numDigits > INT_MAX) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } } else if (!useBig) { @@ -2232,6 +2242,7 @@ Tcl_AppendFormatToObj( } if (toAppend > segmentLimit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendObjToObj(segment, pure); @@ -2285,6 +2296,7 @@ Tcl_AppendFormatToObj( p += sprintf(p, "%d", precision); if (precision > INT_MAX - length) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } length += precision; @@ -2301,11 +2313,13 @@ Tcl_AppendFormatToObj( allocSegment = 1; if (!Tcl_AttemptSetObjLength(segment, length)) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } bytes = TclGetString(segment); if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } break; @@ -2314,6 +2328,7 @@ Tcl_AppendFormatToObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad field specifier \"%c\"", ch)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); } goto error; } @@ -2345,6 +2360,7 @@ Tcl_AppendFormatToObj( Tcl_DecrRefCount(segment); } msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendObjToObj(appendObj, segment); @@ -2367,6 +2383,7 @@ Tcl_AppendFormatToObj( if (numBytes) { if (numBytes > limit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(appendObj, span, numBytes); @@ -2379,6 +2396,7 @@ Tcl_AppendFormatToObj( errorMsg: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL); } error: Tcl_SetObjLength(appendObj, originalLength); diff --git a/generic/tclTimer.c b/generic/tclTimer.c index b6c9208..6682d21 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -831,9 +831,12 @@ Tcl_AfterObjCmd( &index) != TCL_OK)) { index = -1; if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { - Tcl_AppendResult(interp, "bad argument \"", - Tcl_GetString(objv[1]), + const char *arg = Tcl_GetString(objv[1]); + + Tcl_AppendResult(interp, "bad argument \"", arg, "\": must be cancel, idle, info, or an integer", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", + arg, NULL); return TCL_ERROR; } } @@ -947,9 +950,7 @@ Tcl_AfterObjCmd( Tcl_DoWhenIdle(AfterProc, afterPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id)); break; - case AFTER_INFO: { - Tcl_Obj *resultListPtr; - + case AFTER_INFO: if (objc == 2) { for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { @@ -966,17 +967,22 @@ Tcl_AfterObjCmd( } afterPtr = GetAfterEvent(assocPtr, objv[2]); if (afterPtr == NULL) { - Tcl_AppendResult(interp, "event \"", TclGetString(objv[2]), - "\" doesn't exist", NULL); + const char *eventStr = TclGetString(objv[2]); + + Tcl_AppendResult(interp, "event \"", eventStr, "\" doesn't exist", + NULL); + Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); return TCL_ERROR; - } - resultListPtr = Tcl_NewObj(); - Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( - (afterPtr->token == NULL) ? "idle" : "timer", -1)); - Tcl_SetObjResult(interp, resultListPtr); + } else { + Tcl_Obj *resultListPtr = Tcl_NewObj(); + + Tcl_ListObjAppendElement(interp, resultListPtr, + afterPtr->commandPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( + (afterPtr->token == NULL) ? "idle" : "timer", -1)); + Tcl_SetObjResult(interp, resultListPtr); + } break; - } default: Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index d5fb6f6..a60a80b 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -368,6 +368,7 @@ Tcl_TraceObjCmd( badVarOps: Tcl_AppendResult(interp, "bad operations \"", flagOps, "\": should be one or more of rwua", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL); return TCL_ERROR; } @@ -436,6 +437,8 @@ TraceExecutionObjCmd( Tcl_SetResult(interp, "bad operation list \"\": must be " "one or more of enter, leave, enterstep, or leavestep", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", + NULL); return TCL_ERROR; } for (i = 0; i < listLen; i++) { @@ -676,6 +679,8 @@ TraceCommandObjCmd( if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " "one or more of delete or rename", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", + NULL); return TCL_ERROR; } @@ -872,6 +877,8 @@ TraceVariableObjCmd( if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " "one or more of array, read, unset, or write", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", + NULL); return TCL_ERROR; } for (i = 0; i < listLen ; i++) { @@ -2021,6 +2028,7 @@ TraceVarProc( } if (code != TCL_OK) { /* copy error msg to result */ Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(errMsgObj); result = (char *) errMsgObj; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 5e1efde..64aa824 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -470,6 +470,8 @@ Tcl_SplitList( if (interp != NULL) { Tcl_SetResult(interp, "internal error in Tcl_SplitList", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", + NULL); } return TCL_ERROR; } @@ -3270,7 +3272,7 @@ TclReToGlob( { int anchorLeft, anchorRight, lastIsStar, numStars; char *dsStr, *dsStrStart; - const char *msg, *p, *strEnd; + const char *msg, *p, *strEnd, *code; strEnd = reStr + reStrLen; Tcl_DStringInit(dsPtr); @@ -3324,6 +3326,7 @@ TclReToGlob( */ msg = NULL; + code = NULL; p = reStr; anchorRight = 0; lastIsStar = 0; @@ -3380,6 +3383,7 @@ TclReToGlob( break; default: msg = "invalid escape sequence"; + code = "BADESCAPE"; goto invalidGlob; } break; @@ -3408,6 +3412,7 @@ TclReToGlob( case '$': if (p+1 != strEnd) { msg = "$ not anchor"; + code = "NONANCHOR"; goto invalidGlob; } anchorRight = 1; @@ -3415,8 +3420,8 @@ TclReToGlob( case '*': case '+': case '?': case '|': case '^': case '{': case '}': case '(': case ')': case '[': case ']': msg = "unhandled RE special char"; + code = "UNHANDLED"; goto invalidGlob; - break; default: *dsStr++ = *p; break; @@ -3430,6 +3435,7 @@ TclReToGlob( */ msg = "excessive recursive glob backtrack potential"; + code = "OVERCOMPLEX"; goto invalidGlob; } @@ -3458,6 +3464,7 @@ TclReToGlob( #endif if (interp != NULL) { Tcl_AppendResult(interp, msg, NULL); + Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); } Tcl_DStringFree(dsPtr); return TCL_ERROR; -- cgit v0.12 From caf48c369e8ba6e8bcbb7f3a0aa6a0303dc2b56e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Apr 2011 14:01:30 +0000 Subject: Remove unused header file: unix/tclUnixThrd.h --- ChangeLog | 1 + macosx/Tcl.xcode/project.pbxproj | 2 -- macosx/Tcl.xcodeproj/project.pbxproj | 2 -- 3 files changed, 1 insertion(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4724598..fd79840 100644 --- a/ChangeLog +++ b/ChangeLog @@ -14,6 +14,7 @@ * test/error.test: * test/info.test: * test/scan.test: + * unix/tclUnixThrd.h: Remove this unused header file. 2011-04-03 Donal K. Fellows diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj index e62ded2..54d9e02 100644 --- a/macosx/Tcl.xcode/project.pbxproj +++ b/macosx/Tcl.xcode/project.pbxproj @@ -829,7 +829,6 @@ F96D446708F272B9004A47F5 /* tclUnixSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixSock.c; sourceTree = ""; }; F96D446808F272B9004A47F5 /* tclUnixTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTest.c; sourceTree = ""; }; F96D446908F272B9004A47F5 /* tclUnixThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixThrd.c; sourceTree = ""; }; - F96D446A08F272B9004A47F5 /* tclUnixThrd.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclUnixThrd.h; sourceTree = ""; }; F96D446B08F272B9004A47F5 /* tclUnixTime.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTime.c; sourceTree = ""; }; F96D446C08F272B9004A47F5 /* tclXtNotify.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtNotify.c; sourceTree = ""; }; F96D446D08F272B9004A47F5 /* tclXtTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtTest.c; sourceTree = ""; }; @@ -1732,7 +1731,6 @@ F96D446708F272B9004A47F5 /* tclUnixSock.c */, F96D446808F272B9004A47F5 /* tclUnixTest.c */, F96D446908F272B9004A47F5 /* tclUnixThrd.c */, - F96D446A08F272B9004A47F5 /* tclUnixThrd.h */, F96D446B08F272B9004A47F5 /* tclUnixTime.c */, F96D446C08F272B9004A47F5 /* tclXtNotify.c */, F96D446D08F272B9004A47F5 /* tclXtTest.c */, diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index 002ab80..3cc34d7 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -829,7 +829,6 @@ F96D446708F272B9004A47F5 /* tclUnixSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixSock.c; sourceTree = ""; }; F96D446808F272B9004A47F5 /* tclUnixTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTest.c; sourceTree = ""; }; F96D446908F272B9004A47F5 /* tclUnixThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixThrd.c; sourceTree = ""; }; - F96D446A08F272B9004A47F5 /* tclUnixThrd.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclUnixThrd.h; sourceTree = ""; }; F96D446B08F272B9004A47F5 /* tclUnixTime.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTime.c; sourceTree = ""; }; F96D446C08F272B9004A47F5 /* tclXtNotify.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtNotify.c; sourceTree = ""; }; F96D446D08F272B9004A47F5 /* tclXtTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtTest.c; sourceTree = ""; }; @@ -1732,7 +1731,6 @@ F96D446708F272B9004A47F5 /* tclUnixSock.c */, F96D446808F272B9004A47F5 /* tclUnixTest.c */, F96D446908F272B9004A47F5 /* tclUnixThrd.c */, - F96D446A08F272B9004A47F5 /* tclUnixThrd.h */, F96D446B08F272B9004A47F5 /* tclUnixTime.c */, F96D446C08F272B9004A47F5 /* tclXtNotify.c */, F96D446D08F272B9004A47F5 /* tclXtTest.c */, -- cgit v0.12 From 0d695fcd80cec0f53ad553a4b0abacbd29aad68c Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 4 Apr 2011 14:10:01 +0000 Subject: Disable tcl::mathfunc::rmmadwiw by default to make test suite work; automated test frameworks have no mind to read... --- ChangeLog | 3 +++ library/init.tcl | 2 ++ 2 files changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index fd79840..976cc58 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,8 @@ 2011-04-04 Donal K. Fellows + * library/init.tcl (tcl::mathfunc::rmmadwiw): Disable by default to + make test suite work. + * generic/tclBasic.c, generic/tclStringObj.c, generic/tclTimer.c, * generic/tclTrace.c, generic/tclUtil.c: More generation of error codes ([format], [after], [trace], RE optimizer). diff --git a/library/init.tcl b/library/init.tcl index d85fe2a..f1d6a64 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -823,6 +823,7 @@ proc tcl::CopyDirectory {action src dest} { } # TIP 131 +if 0 { proc tcl::rmmadwiw {} { set magic { 42 83 fe f6 ff f8 f1 e5 c6 f9 eb fd ff fb f1 e5 cc f5 ec f5 e3 fd fe @@ -847,3 +848,4 @@ proc tcl::mathfunc::rmmadwiw {} { set matter [lreverse $mind] return [join $matter ""] } +} -- cgit v0.12