diff options
Diffstat (limited to 'generic')
60 files changed, 336 insertions, 206 deletions
diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 9a5571f..7026885 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: regc_locale.c,v 1.21.6.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: regc_locale.c,v 1.23 2010/10/15 15:25:52 nijtmans Exp $ */ /* ASCII character-name table */ diff --git a/generic/tcl.decls b/generic/tcl.decls index f7c5d4f..444ffaa 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.181 2010/09/15 07:33:54 nijtmans Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.182 2011/01/19 14:11:23 nijtmans Exp $ library tcl @@ -62,7 +62,7 @@ declare 8 { } # Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix, -# but they are part of the old interface, so we include them here for +# but they are part of the old generic interface, so we include them here for # compatibility reasons. declare 9 unix { @@ -598,7 +598,7 @@ declare 166 { } # Tcl_GetOpenFile is only available on unix, but it is a part of the old -# interface, so we inlcude it here for compatibility reasons. +# generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, diff --git a/generic/tcl.h b/generic/tcl.h index fd67dd4..670e716 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.308.2.2 2010/12/16 01:42:18 kennykb Exp $ + * RCS: @(#) $Id: tcl.h,v 1.312 2011/01/19 14:11:23 nijtmans Exp $ */ #ifndef _TCL @@ -158,6 +158,11 @@ extern "C" { # define TCL_VARARGS_DEF(type, name) (type name, ...) # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) #endif +#if defined(__GNUC__) && (__GNUC__ > 2) +# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) +#else +# define TCL_FORMAT_PRINTF(a,b) +#endif /* *---------------------------------------------------------------------------- diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 816f0f6..c7bce32 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.465.2.6 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.473 2011/01/18 08:43:53 nijtmans Exp $ */ #include "tclInt.h" @@ -825,7 +825,7 @@ Tcl_CreateInterp(void) Tcl_DisassembleObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); - + /* Adding the bytecode assembler command */ cmdPtr = (Command*) Tcl_NRCreateCommand(interp, "::tcl::unsupported::assemble", @@ -839,7 +839,7 @@ Tcl_CreateInterp(void) TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL); Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, NRCoroInjectObjCmd, NULL, NULL); - + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -954,11 +954,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } /* @@ -968,7 +968,7 @@ Tcl_CreateInterp(void) #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } #endif @@ -8625,7 +8625,7 @@ NRCoroutineCallerCallback( NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); - + if (cmdPtr->flags & CMD_IS_DELETED) { /* * The command was deleted while it was running: wind down the diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 165da34..b9af8c3 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBinary.c,v 1.66.2.2 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.69 2010/12/10 13:08:54 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 4ea1c78..414344a 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -14,7 +14,7 @@ * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.38.4.3 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.43 2010/12/10 21:59:23 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclClock.c b/generic/tclClock.c index c3914a6..a844205 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclClock.c,v 1.75.4.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclClock.c,v 1.76 2010/10/01 12:52:49 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 2d4fc83..01e4a41 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.126.2.2 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.129 2010/12/10 13:08:54 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8900d14..ffb8b98 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.184.2.2 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.188 2011/01/01 10:49:09 dkf Exp $ */ #include "tclInt.h" @@ -29,13 +29,16 @@ */ typedef struct SortElement { - union { + union { /* The value that we sorting by. */ const char *strValuePtr; long intValue; double doubleValue; Tcl_Obj *objValuePtr; - } index; - Tcl_Obj *objPtr; /* Object being sorted, or its index. */ + } collationKey; + union { /* Object being sorted, or its index. */ + Tcl_Obj *objPtr; + int index; + } payload; struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ } SortElement; @@ -3640,6 +3643,7 @@ Tcl_LsortObjCmd( group = 0; groupSize = 1; groupOffset = 0; + indexPtr = NULL; for (i = 1; i < objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { @@ -3672,66 +3676,40 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { + int indexc, dummy; Tcl_Obj **indexv; - /* === START SPECIAL CASE === - * - * When reviewing code flow in this function, note that from here - * to the line a bit below (END SPECIAL CASE) the contents of the - * indexc and indexv fields of the sortInfo structure may not be - * matched, so jumping to the done2 label to exit is wrong. - */ - - if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); - } if (i == objc-2) { Tcl_AppendResult(interp, "\"-index\" option must be " "followed by list index", NULL); - return TCL_ERROR; + sortInfo.resultCode = TCL_ERROR; + goto done2; } - - /* - * Take copy to prevent shimmering problems. - */ - - if (TclListObjGetElements(interp, objv[i+1], &sortInfo.indexc, + if (TclListObjGetElements(interp, objv[i+1], &indexc, &indexv) != TCL_OK) { - return TCL_ERROR; - } - /* === END SPECIAL CASE === */ - - switch (sortInfo.indexc) { - case 0: - sortInfo.indexv = NULL; - break; - case 1: - sortInfo.indexv = &sortInfo.singleIndex; - break; - default: - sortInfo.indexv = - TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); - allocatedIndexVector = 1; /* Cannot use indexc field, as - * it might be decreased by 1 - * later. */ + sortInfo.resultCode = TCL_ERROR; + goto done2; } - /* - * Fill the array by parsing each index. We don't know whether - * their scale is sensible yet, but we at least perform the - * syntactic check here. - */ + /* + * Check each of the indices for syntactic correctness. Note that + * we do not store the converted values here because we do not + * know if this is the only -index option yet and so we can't + * allocate any space; that happens after the scan through all the + * options is done. + */ - for (j=0 ; j<sortInfo.indexc ; j++) { + for (j=0 ; j<indexc ; j++) { if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, - &sortInfo.indexv[j]) != TCL_OK) { + &dummy) != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); sortInfo.resultCode = TCL_ERROR; goto done2; } } - i++; + indexPtr = objv[i+1]; + i++; break; } case LSORT_INTEGER: @@ -3775,6 +3753,35 @@ Tcl_LsortObjCmd( sortInfo.sortMode = SORTMODE_ASCII_NC; } + /* + * Now extract the -index list for real, if present. No failures are + * expected here; the values are all of the right type or convertible to + * it. + */ + + if (indexPtr) { + Tcl_Obj **indexv; + + TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv); + switch (sortInfo.indexc) { + case 0: + sortInfo.indexv = NULL; + break; + case 1: + sortInfo.indexv = &sortInfo.singleIndex; + break; + default: + sortInfo.indexv = + TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + allocatedIndexVector = 1; /* Cannot use indexc field, as it + * might be decreased by 1 later. */ + } + for (j=0 ; j<sortInfo.indexc ; j++) { + TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, + &sortInfo.indexv[j]); + } + } + listObj = objv[objc-1]; if (sortInfo.sortMode == SORTMODE_COMMAND) { @@ -3918,7 +3925,7 @@ Tcl_LsortObjCmd( */ if (sortMode == SORTMODE_ASCII) { - elementArray[i].index.strValuePtr = TclGetString(indexPtr); + elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); } else if (sortMode == SORTMODE_INTEGER) { long a; @@ -3926,7 +3933,7 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done1; } - elementArray[i].index.intValue = a; + elementArray[i].collationKey.intValue = a; } else if (sortInfo.sortMode == SORTMODE_REAL) { double a; @@ -3935,9 +3942,9 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done1; } - elementArray[i].index.doubleValue = a; + elementArray[i].collationKey.doubleValue = a; } else { - elementArray[i].index.objValuePtr = indexPtr; + elementArray[i].collationKey.objValuePtr = indexPtr; } /* @@ -3946,9 +3953,9 @@ Tcl_LsortObjCmd( */ if (indices || group) { - elementArray[i].objPtr = INT2PTR(idx); + elementArray[i].payload.index = idx; } else { - elementArray[i].objPtr = listObjPtrs[idx]; + elementArray[i].payload.objPtr = listObjPtrs[idx]; } /* @@ -3990,7 +3997,7 @@ Tcl_LsortObjCmd( newArray = &listRepPtr->elements; if (group) { for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { - idx = PTR2INT(elementPtr->objPtr); + idx = elementPtr->payload.index; for (j = 0; j < groupSize; j++) { if (indices) { objPtr = Tcl_NewIntObj(idx + j - groupOffset); @@ -4005,13 +4012,13 @@ Tcl_LsortObjCmd( } } else if (indices) { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = Tcl_NewIntObj(PTR2INT(elementPtr->objPtr)); + objPtr = Tcl_NewIntObj(elementPtr->payload.index); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } } else { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = elementPtr->objPtr; + objPtr = elementPtr->payload.objPtr; newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } @@ -4166,25 +4173,25 @@ SortCompare( int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(elemPtr1->index.strValuePtr, - elemPtr2->index.strValuePtr); + order = strcmp(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { - order = strcasecmp(elemPtr1->index.strValuePtr, - elemPtr2->index.strValuePtr); + order = strcasecmp(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { - order = DictionaryCompare(elemPtr1->index.strValuePtr, - elemPtr2->index.strValuePtr); + order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, + elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { long a, b; - a = elemPtr1->index.intValue; - b = elemPtr2->index.intValue; + a = elemPtr1->collationKey.intValue; + b = elemPtr2->collationKey.intValue; order = ((a >= b) - (a <= b)); } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; - a = elemPtr1->index.doubleValue; - b = elemPtr2->index.doubleValue; + a = elemPtr1->collationKey.doubleValue; + b = elemPtr2->collationKey.doubleValue; order = ((a >= b) - (a <= b)); } else { Tcl_Obj **objv, *paramObjv[2]; @@ -4201,8 +4208,8 @@ SortCompare( } - objPtr1 = elemPtr1->index.objValuePtr; - objPtr2 = elemPtr2->index.objValuePtr; + objPtr1 = elemPtr1->collationKey.objValuePtr; + objPtr2 = elemPtr2->collationKey.objValuePtr; paramObjv[0] = objPtr1; paramObjv[1] = objPtr2; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7c30685..c36cd8b 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.214.2.2 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.216 2010/12/10 13:08:53 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c8e8618..807c3e4 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.169.2.3 2010/12/01 16:42:34 kennykb Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.174 2011/01/18 08:43:53 nijtmans Exp $ */ #include "tclInt.h" @@ -393,7 +393,7 @@ TclCompileCatchCmd( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* Stack at this point: ?script? <mark> result TCL_OK */ - /* + /* * Emit the "error case" epilogue. Push the interpreter result * and the return code. */ @@ -411,7 +411,7 @@ TclCompileCatchCmd( /* Stack at this point: ?script? result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); + (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } /* Push the return options if the caller wants them */ @@ -479,7 +479,7 @@ TclCompileCatchCmd( TclEmitOpcode(INST_POP, envPtr); } - /* + /* * Result of all this, on either branch, should have been to leave * one operand -- the return code -- on the stack. */ @@ -1125,7 +1125,7 @@ TclCompileDictUpdateCmd( if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); + (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } TclStackFree(interp, keyTokenPtrs); return TCL_OK; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8fef58d..2f86be1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmdsSZ.c,v 1.9 2010/05/28 09:11:31 dkf Exp $ + * RCS: @(#) $Id: tclCompCmdsSZ.c,v 1.10 2011/01/18 08:43:53 nijtmans Exp $ */ #include "tclInt.h" @@ -717,7 +717,7 @@ TclSubstCompile( /* Start */ if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", - CurrentOffset(envPtr) - startFixup.codeOffset); + (int) (CurrentOffset(envPtr) - startFixup.codeOffset)); } } @@ -774,7 +774,7 @@ TclSubstCompile( /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", - CurrentOffset(envPtr) - breakFixup.codeOffset); + (int) (CurrentOffset(envPtr) - breakFixup.codeOffset)); } TclEmitOpcode(INST_POP, envPtr); TclEmitOpcode(INST_POP, envPtr); @@ -789,7 +789,7 @@ TclSubstCompile( /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", - CurrentOffset(envPtr) - continueFixup.codeOffset); + (int) (CurrentOffset(envPtr) - continueFixup.codeOffset)); } TclEmitOpcode(INST_POP, envPtr); TclEmitOpcode(INST_POP, envPtr); @@ -798,11 +798,11 @@ TclSubstCompile( /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", - CurrentOffset(envPtr) - returnFixup.codeOffset); + (int) (CurrentOffset(envPtr) - returnFixup.codeOffset)); } if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", - CurrentOffset(envPtr) - otherFixup.codeOffset); + (int) (CurrentOffset(envPtr) - otherFixup.codeOffset)); } /* @@ -826,7 +826,7 @@ TclSubstCompile( /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", - CurrentOffset(envPtr) - okFixup.codeOffset); + (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { TclEmitInstInt1(INST_CONCAT1, count, envPtr); @@ -836,7 +836,7 @@ TclSubstCompile( /* CONTINUE jump to here */ if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", - CurrentOffset(envPtr) - endFixup.codeOffset); + (int) (CurrentOffset(envPtr) - endFixup.codeOffset)); } bline = envPtr->line; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index ead8f51..97410df 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.105.2.1 2010/09/27 20:33:37 kennykb Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.107 2011/01/18 08:43:53 nijtmans Exp $ */ #include "tclInt.h" @@ -1381,13 +1381,13 @@ ParseExpr( Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) - ? (start - parsePtr->string) : limit - 3, + ? (int) (start - parsePtr->string) : limit - 3, ((start - limit) < parsePtr->string) ? parsePtr->string : start - limit + 3, (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", (start + scanned + limit > parsePtr->end) - ? parsePtr->end - (start + scanned) : limit-3, + ? (int) (parsePtr->end - start) - scanned : limit-3, start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 833a920..96d9896 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.187.2.5 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.194 2010/12/10 21:59:23 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3c9350a..0df13d9 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.126.2.2 2010/10/23 15:49:54 kennykb Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.128 2010/10/20 20:52:28 ferrieux Exp $ */ #ifndef _TCLCOMPILATION diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1b44b7d..33760f7 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.186.2.2 2010/12/01 16:42:35 kennykb Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.189 2011/01/19 14:11:23 nijtmans Exp $ */ #ifndef _TCLDECLS @@ -46,7 +46,7 @@ EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ -EXTERN void Tcl_Panic(const char *format, ...); +EXTERN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ EXTERN char * Tcl_Alloc(unsigned int size); /* 4 */ @@ -1664,10 +1664,10 @@ EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 578 */ -EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...); +EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 579 */ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, - const char *format, ...); + const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 580 */ EXTERN int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, @@ -1822,7 +1822,7 @@ typedef struct TclStubs { int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ - void (*tcl_Panic) (const char *format, ...); /* 2 */ + void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ char * (*tcl_Alloc) (unsigned int size); /* 3 */ void (*tcl_Free) (char *ptr); /* 4 */ char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */ @@ -2422,8 +2422,8 @@ typedef struct TclStubs { void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, int length, int limit, const char *ellipsis); /* 575 */ Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */ int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */ - Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...); /* 578 */ - void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...); /* 579 */ + Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */ + void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 579 */ int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, int flags); /* 580 */ int (*tcl_Canceled) (Tcl_Interp *interp, int flags); /* 581 */ int (*tcl_CreatePipe) (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 582 */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 8affede..358b313 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDictObj.c,v 1.84.2.1 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.85 2010/12/10 13:08:53 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 4dfd8ab..add30e4 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEncoding.c,v 1.72.2.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclEncoding.c,v 1.73 2010/10/01 12:52:49 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 1bf9be1..ae90b9b 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEnsemble.c,v 1.5.4.1 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclEnsemble.c,v 1.7 2011/01/18 08:43:53 nijtmans Exp $ */ #include "tclInt.h" @@ -1513,7 +1513,7 @@ TclMakeEnsemble( Tcl_DStringSetLength(&hiddenBuf, hiddenLen); if (Tcl_HideCommand(interp, "___tmp", Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { - Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } } else { /* diff --git a/generic/tclEnv.c b/generic/tclEnv.c index a7ad13f..5a13044 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEnv.c,v 1.43.2.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclEnv.c,v 1.44 2010/10/01 12:52:49 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 67b3fde..ba2bb64 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.93.2.1 2010/09/25 14:51:12 kennykb Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.94 2010/09/23 18:08:35 dgp Exp $ */ #include "tclInt.h" diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7a8f082..c34f975 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.494.2.9 2010/12/01 16:42:35 kennykb Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.511 2010/12/30 23:10:07 msofer Exp $ */ #include "tclInt.h" @@ -188,12 +188,12 @@ typedef struct BottomData { BP->cleanup = cleanup; \ TclNRAddCallback(interp, TEBCresume, BP, \ INT2PTR(invoke), NULL, NULL) - + #define NR_DATA_DIG() \ pc = BP->pc; \ cleanup = BP->cleanup; \ tosPtr = esPtr->tosPtr - + #define PUSH_TAUX_OBJ(objPtr) \ do { \ @@ -1062,14 +1062,14 @@ GrowEvaluationStack( /* * Reset move to hold the number of words to be moved to new stack (if - * any) and growth to hold the complete stack requirements: add the marker - * and maximal possible offset. + * any) and growth to hold the complete stack requirements: add one for + * the marker, (WALLOCALIGN-1) for the maximal possible offset. */ if (move) { moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1; } - needed = growth + moveWords + WALLOCALIGN - 1; + needed = growth + moveWords + WALLOCALIGN; /* * Check if there is enough room in the next stack (if there is one, it diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 277afa6..050c5dc 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFCmd.c,v 1.51.4.1 2010/12/11 18:39:28 kennykb Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.52 2010/12/09 15:09:07 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclHash.c b/generic/tclHash.c index d5ce21f..c7a550f 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclHash.c,v 1.46.2.2 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclHash.c,v 1.48 2010/12/10 21:59:23 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclIO.c b/generic/tclIO.c index 0f490b3..adc630f 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.175.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.176 2010/12/10 17:00:12 ferrieux Exp $ */ #include "tclInt.h" diff --git a/generic/tclIO.h b/generic/tclIO.h index ad57391..8616c69 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.h,v 1.17.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIO.h,v 1.18 2010/12/10 21:59:24 nijtmans Exp $ */ /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index fe7fc36..38df785 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.69.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.72 2011/01/17 11:27:30 nijtmans Exp $ */ #include "tclInt.h" @@ -135,32 +135,26 @@ Tcl_PutsObjCmd( break; case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */ + newline = 0; if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { chanObjPtr = objv[2]; string = objv[3]; - } else { + break; +#if TCL_MAJOR_VERSION < 9 + } else if (strcmp(TclGetString(objv[2]), "nonewline") == 0) { /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or - * documented. + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. */ - const char *arg; - int length; - - arg = TclGetStringFromObj(objv[3], &length); - if ((length != 9) - || (strncmp(arg, "nonewline", (size_t) length) != 0)) { - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", NULL); - return TCL_ERROR; - } chanObjPtr = objv[1]; string = objv[2]; + break; +#endif } - newline = 0; - break; - + /* Fall through */ default: /* [puts] or [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); @@ -428,25 +422,31 @@ Tcl_ReadObjCmd( i++; /* Consumed channel name. */ /* - * Compute how many bytes to read, and see whether the final newline - * should be dropped. + * Compute how many bytes to read. */ toRead = -1; if (i < objc) { - const char *arg; + if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { +#if TCL_MAJOR_VERSION < 9 + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. + */ - arg = TclGetString(objv[i]); - if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ - if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { - return TCL_ERROR; + if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { +#endif + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected non-negative integer but got \"", + TclGetString(objv[i]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + return TCL_ERROR; +#if TCL_MAJOR_VERSION < 9 } - } else if (strcmp(arg, "nonewline") == 0) { newline = 1; - } else { - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", NULL); - return TCL_ERROR; +#endif } } diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index a8b2674..884ec65 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOSock.c,v 1.11.10.4 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIOSock.c,v 1.15 2010/12/10 15:44:54 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 42ab1f3..6683ff9 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.177.2.1 2010/09/22 01:08:49 kennykb Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.178 2010/09/22 00:57:11 hobbs Exp $ */ #include "tclInt.h" diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index dd66ec6..061ba90 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIndexObj.c,v 1.59.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.60 2010/12/10 13:08:54 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclInt.decls b/generic/tclInt.decls index ac246f0..5b7e8dc 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.148.2.4 2010/12/11 18:39:29 kennykb Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.153 2010/12/10 15:44:53 nijtmans Exp $ library tcl @@ -996,7 +996,7 @@ declare 248 { int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr) } - + declare 249 { char* TclDoubleDigits(double dv, int ndigits, int flags, int* decpt, int* signum, char** endPtr) diff --git a/generic/tclInt.h b/generic/tclInt.h index ea8f948..b16c7df 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.482.2.6 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.490 2010/12/10 21:59:23 nijtmans Exp $ */ #ifndef _TCLINT diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 8be8577..cae5e4e 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.142.2.4 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.147 2010/12/10 15:44:53 nijtmans Exp $ */ #ifndef _TCLINTDECLS diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index ceda11c..b15dd84 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -9,7 +9,7 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.44.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.45 2010/12/10 15:44:53 nijtmans Exp $ */ #ifndef _TCLINTPLATDECLS diff --git a/generic/tclInterp.c b/generic/tclInterp.c index c32daa1..6ccde87 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInterp.c,v 1.113.2.1 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.114 2010/11/15 21:34:54 andreas_kupries Exp $ */ #include "tclInt.h" diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 69aa2b2..93dd950 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoad.c,v 1.26.2.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclLoad.c,v 1.27 2010/10/01 12:52:49 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclMain.c b/generic/tclMain.c index 4cb9c27..f1a6ce7 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMain.c,v 1.50.2.3 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.57 2010/11/15 10:12:38 nijtmans Exp $ */ /** @@ -652,7 +652,7 @@ Tcl_MainEx( Tcl_Release(interp); Tcl_Exit(exitCode); } - + #ifndef UNICODE void Tcl_Main( diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 2e5decc..baed244 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -22,7 +22,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.212.2.3 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.216 2010/11/18 00:44:39 msofer Exp $ */ #include "tclInt.h" diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 2fefa31..bb10ca5 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOMethod.c,v 1.26.2.3 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclOOMethod.c,v 1.31 2011/01/18 15:44:41 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -41,6 +41,8 @@ typedef struct { Tcl_Obj *nameObj; /* The "name" of the command. */ Command cmd; /* The command structure. Mostly bogus. */ ExtraFrameInfo efi; /* Extra information used for [info frame]. */ + Command *oldCmdPtr; /* Saved cmdPtr so that we can be safe after a + * recursive call returns. */ struct PNI pni; /* Specialist information used in the efi * field for this type of call. */ } PMFrameData; @@ -711,6 +713,13 @@ InvokeProcedureMethod( result = pmPtr->preCallProc(pmPtr->clientData, interp, context, (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { + /* + * Restore the old cmdPtr so that a subsequent use of [info frame] + * won't crash on us. [Bug 3001438] + */ + + pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; + Tcl_PopCallFrame(interp); TclStackFree(interp, fdPtr->framePtr); if (--pmPtr->refCount < 1) { @@ -752,6 +761,13 @@ FinalizePMCall( } /* + * Restore the old cmdPtr so that a subsequent use of [info frame] won't + * crash on us. [Bug 3001438] + */ + + pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; + + /* * Scrap the special frame data now that we're done with it. Note that we * are inlining DeleteProcedureMethod() here; this location is highly * sensitive when it comes to performance! @@ -820,6 +836,14 @@ PushMethodCallFrame( } /* + * Save the old cmdPtr so that when this recursive call returns, we can + * restore it. To do otherwise causes crashes in [info frame] after we + * return from a recursive call. [Bug 3001438] + */ + + fdPtr->oldCmdPtr = pmPtr->procPtr->cmdPtr; + + /* * Compile the body. This operation may fail. */ @@ -845,7 +869,7 @@ PushMethodCallFrame( result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr); if (result != TCL_OK) { - return result; + goto failureReturn; } /* @@ -856,7 +880,7 @@ PushMethodCallFrame( result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD); if (result != TCL_OK) { - return result; + goto failureReturn; } fdPtr->framePtr->clientData = contextPtr; @@ -891,6 +915,15 @@ PushMethodCallFrame( } return TCL_OK; + + /* + * Restore the old cmdPtr so that a subsequent use of [info frame] won't + * crash on us. [Bug 3001438] + */ + + failureReturn: + pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; + return result; } /* diff --git a/generic/tclObj.c b/generic/tclObj.c index 3161a46..4c9bd98 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.174.2.3 2010/10/02 16:04:29 kennykb Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.177 2010/10/02 11:37:02 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclPanic.c b/generic/tclPanic.c index e8c1257..3a48afa 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -12,10 +12,13 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPanic.c,v 1.14.4.2 2010/12/16 01:42:18 kennykb Exp $ + * RCS: @(#) $Id: tclPanic.c,v 1.21 2011/01/12 20:17:03 nijtmans Exp $ */ #include "tclInt.h" +#ifdef _WIN32 + MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); +#endif /* * The panicProc variable contains a pointer to an application specific panic @@ -44,6 +47,10 @@ void Tcl_SetPanicProc( Tcl_PanicProc *proc) { +#ifdef _WIN32 + /* tclWinDebugPanic only installs if there is no panicProc yet. */ + if ((proc != tclWinDebugPanic) || (panicProc == NULL)) +#endif panicProc = proc; } @@ -84,6 +91,10 @@ Tcl_PanicVA( if (panicProc != NULL) { panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#ifdef _WIN32 + } else if (IsDebuggerPresent()) { + tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#endif } else { fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); @@ -91,7 +102,20 @@ Tcl_PanicVA( fflush(stderr); } /* In case the users panic proc does not abort, we do it here */ +#ifdef _WIN32 +# if defined(__GNUC__) + __builtin_trap(); +# elif defined(_WIN64) + __debugbreak(); +# elif defined(_MSC_VER) + _asm {int 3} +# else + DebugBreak(); +# endif + ExitProcess(1); +#else abort(); +#endif } /* diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 3bd4c53..fd4651f 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPathObj.c,v 1.88.4.1 2010/09/22 01:08:49 kennykb Exp $ + * RCS: @(#) $Id: tclPathObj.c,v 1.89 2010/09/22 00:57:11 hobbs Exp $ */ #include "tclInt.h" diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index f90e4bc..5612f41 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPreserve.c,v 1.12 2009/01/09 11:21:46 dkf Exp $ + * RCS: @(#) $Id: tclPreserve.c,v 1.14 2011/01/25 07:17:26 nijtmans Exp $ */ #include "tclInt.h" @@ -240,7 +240,7 @@ Tcl_Release( * Reference not found. This is a bug in the caller. */ - Tcl_Panic("Tcl_Release couldn't find reference for 0x%x", clientData); + Tcl_Panic("Tcl_Release couldn't find reference for %p", clientData); } /* @@ -280,7 +280,7 @@ Tcl_EventuallyFree( continue; } if (refPtr->mustFree) { - Tcl_Panic("Tcl_EventuallyFree called twice for 0x%x", clientData); + Tcl_Panic("Tcl_EventuallyFree called twice for %p", clientData); } refPtr->mustFree = 1; refPtr->freeProc = freeProc; diff --git a/generic/tclProc.c b/generic/tclProc.c index 92e4169..bfc101c 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.181.2.2 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.183 2010/12/10 21:59:23 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index f247572..86ce07c 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclRegexp.c,v 1.34.4.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclRegexp.c,v 1.35 2010/10/01 12:52:50 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclResolve.c b/generic/tclResolve.c index aaa19ea..109948e 100644 --- a/generic/tclResolve.c +++ b/generic/tclResolve.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclResolve.c,v 1.12.4.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclResolve.c,v 1.13 2010/10/01 12:52:50 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclResult.c b/generic/tclResult.c index 2d319e9..ee15190 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclResult.c,v 1.61.2.2 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.63 2010/10/01 12:52:50 dkf Exp $ */ #include "tclInt.h" diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 76895df..67c797f 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -12,9 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStrToD.c,v 1.46.2.2 2010/12/11 18:39:29 kennykb Exp $ - * - *---------------------------------------------------------------------- + * RCS: @(#) $Id: tclStrToD.c,v 1.54 2011/01/15 19:01:31 kennykb Exp $ */ #include "tclInt.h" @@ -3088,6 +3086,11 @@ StrictInt64Conversion( if (i == ilim) { if (2*b > S || (2*b == S && (digit & 1) != 0)) { s = BumpUp(s, retval, &k); + } else { + while (*--s == '0') { + /* do nothing */ + } + ++s; } break; } @@ -3496,6 +3499,10 @@ StrictBignumConversionPowD( if (ShouldBankerRoundUpPowD(&b, sd, digit&1)) { s = BumpUp(s, retval, &k); } + while (*--s == '0') { + /* do nothing */ + } + ++s; break; } @@ -3768,7 +3775,7 @@ ShorteningBignumConversion( --s5; /* - * TODO: It might possibly be a win to fall back to int64 + * IDEA: It might possibly be a win to fall back to int64 * arithmetic here if S < 2**64/10. But it's a win only for * a fairly narrow range of magnitudes so perhaps not worth * bothering. We already know that we shorten the @@ -3968,6 +3975,10 @@ StrictBignumConversion( } } } + while (*--s == '0') { + /* do nothing */ + } + ++s; /* * Endgame - store the location of the decimal point and the end of the @@ -4025,9 +4036,10 @@ StrictBignumConversion( * choosing the one that is closest to the given number (and * resolving ties with 'round to even'). It is allowed to return * fewer than 'ndigits' if the number converts exactly; if the - * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it is - * also allowed to return fewer digits if the shorter string will - * still reconvert to the given input number. + * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it + * also returns fewer digits if the shorter string will still + * reconvert without loss to the given input number. In any case, + * strings of trailing zeroes are suppressed. * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f format * conversion. It requests that conversion proceed until * 'ndigits' digits after the decimal point have been converted. @@ -4037,7 +4049,8 @@ StrictBignumConversion( * number that converts exactly, and changing the argument to * TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow the routine * also to return fewer digits if the shorter string will still - * reconvert without loss to the given input number. + * reconvert without loss to the given input number. Strings of + * trailing zeroes are suppressed. * * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag requires * all calculations to be done in exact arithmetic. Normally, E and F diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 146f456..96e01d0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -33,7 +33,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStringObj.c,v 1.137.2.1 2010/10/20 01:50:19 kennykb Exp $ */ + * RCS: @(#) $Id: tclStringObj.c,v 1.138 2010/10/19 22:50:37 dkf Exp $ */ #include "tclInt.h" #include "tommath.h" diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 152a181..98ef9b7 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.197.2.1 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.199 2010/11/30 18:17:26 hobbs Exp $ */ #include "tclInt.h" diff --git a/generic/tclTest.c b/generic/tclTest.c index f03b486..e12153d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.153.2.2 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.157 2011/01/18 08:43:53 nijtmans Exp $ */ #include <math.h> @@ -4492,7 +4492,7 @@ TestpanicCmd( */ argString = Tcl_Merge(argc-1, argv+1); - Tcl_Panic(argString); + Tcl_Panic("%s", argString); ckfree((char *)argString); return TCL_OK; diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 8bc68ca..486dcda 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadTest.c,v 1.35.4.1 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclThreadTest.c,v 1.36 2010/12/01 09:58:52 nijtmans Exp $ */ #ifndef USE_TCL_STUBS diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 6fef7ae..c5974da 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTimer.c,v 1.42.4.1 2010/10/30 15:20:23 kennykb Exp $ + * RCS: @(#) $Id: tclTimer.c,v 1.43 2010/10/29 16:42:01 ferrieux Exp $ */ #include "tclInt.h" diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index fd2dc40..4f6bc70 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclTomMath.decls,v 1.8.2.1 2010/12/01 16:42:36 kennykb Exp $ +# RCS: @(#) $Id: tclTomMath.decls,v 1.9 2010/11/28 23:20:11 kennykb Exp $ library tcl @@ -219,4 +219,4 @@ declare 61 { } declare 62 { int TclBN_mp_set_int(mp_int* a, unsigned long i) -}
\ No newline at end of file +} diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 849f08f..4e55ce1 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTomMathDecls.h,v 1.13.2.1 2010/12/01 16:42:36 kennykb Exp $ + * RCS: @(#) $Id: tclTomMathDecls.h,v 1.14 2010/11/28 23:20:11 kennykb Exp $ */ #ifndef _TCLTOMMATHDECLS diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 755614a..efbfbb7 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTrace.c,v 1.60.2.1 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.61 2010/12/06 09:01:49 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 1aacd1d..0e31b1a 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -8,7 +8,7 @@ * Copyright (c) 1998 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclUniData.c,v 1.5.2.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclUniData.c,v 1.7 2010/10/15 15:25:52 nijtmans Exp $ */ /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2e435e6..3a42a32 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.117.2.3 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.124 2011/01/15 18:10:19 kennykb Exp $ */ #include "tclInt.h" @@ -2268,12 +2268,52 @@ Tcl_PrintDouble( /* * Ordinary (normal and denormal) values. */ - + if (*precisionPtr == 0) { digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, &exponent, &signum, &end); } else { - digits = TclDoubleDigits(value, *precisionPtr, TCL_DD_E_FORMAT, + /* + * 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". + * + * 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: + * + * % expr 0.1 + * 0.10000000000000001 + * % expr 0.01 + * 0.01 + * % expr 1e-7 + * 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). + * + * 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, + TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, &exponent, &signum, &end); } if (signum) { @@ -2294,7 +2334,15 @@ Tcl_PrintDouble( c = *++p; } } - sprintf(dst, "e%+d", exponent); + /* + * 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 { + sprintf(dst, "e%+03d", exponent); + } } else { /* * F format for others. diff --git a/generic/tclVar.c b/generic/tclVar.c index 2d67a7c..9a97146 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.203.2.3 2010/12/11 18:39:29 kennykb Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.206 2010/12/10 13:08:53 nijtmans Exp $ */ #include "tclInt.h" diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 5a373c6..dfa58ea 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclZlib.c,v 1.38.2.1 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclZlib.c,v 1.40 2010/10/19 22:50:37 dkf Exp $ */ #include "tclInt.h" @@ -1229,7 +1229,7 @@ Tcl_ZlibDeflate( if (!interp) { return TCL_ERROR; } - + /* * Compressed format is specified by the wbits parameter. See zlib.h for * details. |