From b7b7a76f55e9cf3a0233401d12077c2a4c02fb58 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 1 Jul 2007 17:31:20 +0000 Subject: merge updates from HEAD --- ChangeLog | 91 +- doc/DictObj.3 | 32 +- generic/tclAlloc.c | 48 +- generic/tclBasic.c | 189 +-- generic/tclCmdIL.c | 20 +- generic/tclCompCmds.c | 4 +- generic/tclDate.c | 277 ++-- generic/tclExecute.c | 238 +-- generic/tclFCmd.c | 4 +- generic/tclGetDate.y | 5 +- generic/tclIOCmd.c | 4 +- generic/tclInt.h | 37 +- generic/tclMathOp.c | 2884 ---------------------------------- generic/tclTestObj.c | 67 +- generic/tclThread.c | 20 +- generic/tclThreadAlloc.c | 102 +- generic/tclTrace.c | 4 +- macosx/README | 27 +- macosx/Tcl-Common.xcconfig | 3 +- macosx/Tcl.xcodeproj/default.pbxuser | 5 +- macosx/Tcl.xcodeproj/project.pbxproj | 57 +- unix/Makefile.in | 8 +- win/Makefile.in | 3 +- win/makefile.bc | 1 - win/makefile.vc | 3 +- win/tclWinFile.c | 80 +- 26 files changed, 476 insertions(+), 3737 deletions(-) delete mode 100644 generic/tclMathOp.c diff --git a/ChangeLog b/ChangeLog index f09f8a7..9e61c15 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,58 @@ +2007-06-30 Donal K. Fellows + + * generic/tclCmdIL.c (Tcl_LsortObjCmd): Plug a memory leak caused by + a missing Tcl_DecrRefCount on an error path. [Bug 1717186] + +2007-06-30 Zoran Vasiljevic + + * generic/tclThread.c: Prevent RemeberSyncObj() from growing the sync + object lists by reusing already free'd slots, if possible. See + discussion on Bug 1726873 for more information. + +2007-06-29 Donal K. Fellows + + * doc/DictObj.3 (Tcl_DictObjDone): Improved documentation of this + function to make it clearer how to use it. [Bug 1710795] + +2007-06-29 Daniel Steffen + + * generic/tclAlloc.c: on Darwin, ensure memory allocated by + * generic/tclThreadAlloc.c: the custom TclpAlloc()s is aligned to + 16 byte boundaries (as is the case with the Darwin system malloc). + + * generic/tclGetDate.y: use ckalloc/ckfree instead of malloc/free. + * generic/tclDate.c: bison 1.875e + + * generic/tclBasic.c (TclEvalEx): fix warnings. + + * macosx/Tcl.xcodeproj/project.pbxproj: improve support for renamed tcl + * macosx/Tcl.xcodeproj/default.pbxuser: source dir; add 10.5 SDK build + * macosx/Tcl-Common.xcconfig: config; remove tclMathOp.c. + + * macosx/README: document Tcl.xcodeproj changes. + +2007-06-28 Don Porter + + * generic/tclBasic.c: Removed dead code, including the + * generic/tclExecute.c: entire file tclMathOp.c. + * generic/tclInt.h: + * generic/tclMathOp.c (removed): + * generic/tclTestObj.c: + * win/tclWinFile.c: + + * unix/Makefile.in: Updated to reflect deletion of tclMathOp.c. + * win/Makefile.in: + * win/makefile.bc: + * win/makefile.vc: + +2007-06-28 Pat Thoyts + + * generic/tclBasic.c: Silence constness warnings for TclStackFree + * generic/tclCompCmds.c: when building with msvc. + * generic/tclFCmd.c: + * generic/tclIOCmd.c: + * generic/tclTrace.c: + 2007-06-28 Miguel Sofer * generic/tclVar.c (UnsetVarStruct): fix possible segfault. @@ -11,8 +66,8 @@ 2007-06-26 Don Porter - * generic/tclBasic.c (TclEvalEx): Moved some arrays from the - C stack to the Tcl stack. + * generic/tclBasic.c (TclEvalEx): Moved some arrays from the C + stack to the Tcl stack. 2007-06-26 Miguel Sofer @@ -31,10 +86,10 @@ 2007-06-24 Miguel Sofer - * generic/tclVar.c (TclDeleteCompiledLocalVars): removed inlining - that ended up not really optimising (limited benchmarks). Now - calling UnsetVarStruct (streamlined old code is #ifdef'ed out, in - case better benchmarks do show a difference). + * generic/tclVar.c (TclDeleteCompiledLocalVars): removed inlining that + ended up not really optimising (limited benchmarks). Now calling + UnsetVarStruct (streamlined old code is #ifdef'ed out, in case better + benchmarks do show a difference). * generic/tclVar.c (UnsetVarStruct): fixed a leak introduced in last commit. @@ -44,7 +99,7 @@ * generic/tclVar.c (UnsetVarStruct, TclDeleteVars): made the logic slightly clearer, eliminated some duplicated code. - *** POTENTIAL INCOMPATIBILITY *** (tclInt.h and Var struct users) + *** POTENTIAL INCOMPATIBILITY *** (tclInt.h and Var struct users) The core never builds VAR_LINK variable to have traces. Such a "monster", should one exist, will now have its unset traces called *before* it is unlinked. @@ -68,16 +123,16 @@ 2007-06-21 Don Porter * generic/tclBasic.c: Move most instances of the Tcl_Parse struct - * generic/tclCompExpr.c: off the C stack and onto the Tcl stack. - * generic/tclCompile.c: This is a rather large struct (> 3kB). + * generic/tclCompExpr.c: off the C stack and onto the Tcl stack. This + * generic/tclCompile.c: is a rather large struct (> 3kB). * generic/tclParse.c: 2007-06-21 Miguel Sofer - * generic/tclBasic.c (TEOvI): Made sure that leave - * generic/tclExecute.c (INST_INVOKE): traces that were created - * tests/trace.test (trace-36.2): during execution of an - originally untraced command do not fire [Bug 1740962], partial fix. + * generic/tclBasic.c (TEOvI): Made sure that leave traces + * generic/tclExecute.c (INST_INVOKE): that were created during + * tests/trace.test (trace-36.2): execution of an originally + untraced command do not fire [Bug 1740962], partial fix. 2007-06-21 Donal K. Fellows @@ -136,13 +191,13 @@ * generic/tclProc.c (Tcl_ProcObjCmd, SetLambdaFromAny): Moved the CmdFrame off the C stack and onto the Tcl stack. - * generic/tclExecute.c (TEBC): Moved the CmdFrame off the C stack - and onto the Tcl stack, between the catch and the execution stacks - + * generic/tclExecute.c (TEBC): Moved the CmdFrame off the C stack and + onto the Tcl stack, between the catch and the execution stacks + 2007-06-18 Don Porter - * generic/tclBasic.c (TclEvalEx,TclEvalObjEx): Moved the CmdFrame - off the C stack and onto the Tcl stack. + * generic/tclBasic.c (TclEvalEx,TclEvalObjEx): Moved the CmdFrame off + the C stack and onto the Tcl stack. 2007-06-17 Donal K. Fellows diff --git a/doc/DictObj.3 b/doc/DictObj.3 index fb9206e..107d2ef 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: DictObj.3,v 1.8 2004/10/07 15:15:36 dkf Exp $ +'\" RCS: @(#) $Id: DictObj.3,v 1.8.12.1 2007/07/01 17:31:22 dgp Exp $ '\" .so man.macros .TH Tcl_DictObj 3 8.5 Tcl "Tcl Library Procedures" @@ -158,16 +158,20 @@ The order of iteration is implementation-defined. If the \fBTcl_DictObjFirst\fR returns \fBTCL_ERROR\fR and the iteration is not commenced, and otherwise it returns \fBTCL_OK\fR. .PP -If the last call to \fBTcl_DictObjFirst\fR or \fBTcl_DictObjNext\fR -(for a particular \fIsearchPtr\fR) set the variable indicated by the -\fIdonePtr\fR argument to zero but no further key/value pairs are -desired from that particular iteration, the \fIsearchPtr\fR argument -must be passed to \fBTcl_DictObjDone\fR to release any internal locks -held by the searching process. If \fBTcl_DictObjNext\fR is called on -a particular \fIsearchPtr\fR after \fBTcl_DictObjDone\fR is called on -it, the variable pointed to by \fIdonePtr\fR will always be set to 1 -(and nothing else will happen). It is safe to call -\fBTcl_DictObjDone\fR multiple times on the same \fIsearchPtr\fR. +When \fBTcl_DictObjFirst\fR is called upon a dictionary, a lock is placed on +the dictionary to enable that dictionary to be iterated over safely without +regard for whether the dictionary is modified during the iteration. Because of +this, once the iteration over a dictionary's keys has finished (whether +because all values have been iterated over as indicated by the variable +indicated by the \fIdonePtr\fR argument being set to one, or because no +further values are required) the \fBTcl_DictObjDone\fR function must be called +with the same \fIsearchPtr\fR as was passed to \fBTcl_DictObjFirst\fR so that +the internal locks can be released. Once a particular \fIsearchPtr\fR is +passed to \fBTcl_DictObjDone\fR, passing it to \fBTcl_DictObjNext\fR (without +first initializing it with \fBTcl_DictObjFirst\fR) will result in no values +being produced and the variable pointed to by \fIdonePtr\fR being set to one. +It is safe to call \fBTcl_DictObjDone\fR multiple times on the same +\fIsearchPtr\fR for each call to \fBTcl_DictObjFirst\fR. .PP The procedures \fBTcl_DictObjPutKeyList\fR and \fBTcl_DictObjRemoveKeyList\fR are the close analogues of @@ -203,11 +207,11 @@ int done; * is performed. However it is safe to try to release the lock * even if we've finished iterating over the loop. */ -if (Tcl_DictObjFirst(interp, objPtr, &search, +if (\fBTcl_DictObjFirst\fR(interp, objPtr, &search, &key, &value, &done) != TCL_OK) { return TCL_ERROR; } -for (; done ; Tcl_DictObjNext(&search, &key, &value, &done)) { +for (; done ; \fBTcl_DictObjNext\fR(&search, &key, &value, &done)) { /* * Note that strcmp() is not a good way of comparing * objects and is just used here for demonstration @@ -217,7 +221,7 @@ for (; done ; Tcl_DictObjNext(&search, &key, &value, &done)) { break; } } -Tcl_DictObjDone(&search); +\fBTcl_DictObjDone\fR(&search); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!done)); return TCL_OK; .CE diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index df6db05..3d34113 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.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: tclAlloc.c,v 1.24 2007/04/17 14:49:53 dkf Exp $ + * RCS: @(#) $Id: tclAlloc.c,v 1.24.2.1 2007/07/01 17:31:22 dgp Exp $ */ /* @@ -44,6 +44,16 @@ typedef unsigned long caddr_t; #endif /* + * Alignment for allocated memory. + */ + +#if defined(__APPLE__) +#define ALLOCALIGN 16 +#else +#define ALLOCALIGN 8 +#endif + +/* * The overhead on a block is at least 8 bytes. When free, this space contains * a pointer to the next free block, and the bottom two bits must be zero. * When in use, the first byte is set to MAGIC, and the second byte is the @@ -55,17 +65,17 @@ typedef unsigned long caddr_t; */ union overhead { - union overhead *next; /* when free */ - unsigned char padding[8]; /* Ensure the structure is 8-byte aligned. */ + union overhead *next; /* when free */ + unsigned char padding[ALLOCALIGN]; /* align struct to ALLOCALIGN bytes */ struct { - unsigned char magic0; /* magic number */ - unsigned char index; /* bucket # */ - unsigned char unused; /* unused */ - unsigned char magic1; /* other magic number */ + unsigned char magic0; /* magic number */ + unsigned char index; /* bucket # */ + unsigned char unused; /* unused */ + unsigned char magic1; /* other magic number */ #ifdef RCHECK - unsigned short rmagic; /* range magic number */ - unsigned long size; /* actual block size */ - unsigned short unused2; /* padding to 8-byte align */ + unsigned short rmagic; /* range magic number */ + unsigned long size; /* actual block size */ + unsigned short unused2; /* padding to 8-byte align */ #endif } ovu; #define overMagic0 ovu.magic0 @@ -96,11 +106,12 @@ union overhead { /* * nextf[i] is the pointer to the next free block of size 2^(i+3). The - * smallest allocatable block is 8 bytes. The overhead information precedes - * the data area returned to the user. + * smallest allocatable block is MINBLOCK bytes. The overhead information + * precedes the data area returned to the user. */ -#define NBUCKETS 13 +#define MINBLOCK ((sizeof(union overhead) + (ALLOCALIGN-1)) & ~(ALLOCALIGN-1)) +#define NBUCKETS (13 - (MINBLOCK >> 4)) #define MAXMALLOC (1<<(NBUCKETS+2)) static union overhead *nextf[NBUCKETS]; @@ -211,7 +222,7 @@ TclInitAlloc(void) void TclFinalizeAllocSubsystem(void) { - int i; + unsigned int i; struct block *blockPtr, *nextPtr; Tcl_MutexLock(allocMutexPtr); @@ -319,13 +330,8 @@ TclpAlloc( * for accounting. */ -#ifndef RCHECK - amount = 8; /* size of first bucket */ - bucket = 0; -#else - amount = 16; /* size of first bucket */ - bucket = 1; -#endif + amount = MINBLOCK; /* size of first bucket */ + bucket = MINBLOCK >> 4; while (numBytes + OVERHEAD > amount) { amount <<= 1; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5b9f274..8a1fba1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.244.2.8 2007/06/27 01:37:43 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.244.2.9 2007/07/01 17:31:22 dgp Exp $ */ #include "tclInt.h" @@ -2021,7 +2021,7 @@ TclInvokeStringCommand( result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv); - TclStackFree(interp, argv); + TclStackFree(interp, (void *)argv); return result; } @@ -2936,10 +2936,6 @@ Tcl_CreateMathFunc( OldMathFuncData *data = (OldMathFuncData *) ckalloc(sizeof(OldMathFuncData)); - if (numArgs > MAX_MATH_ARGS) { - Tcl_Panic("attempt to create a math function with too many args"); - } - data->proc = proc; data->numArgs = numArgs; data->argTypes = (Tcl_ValueType*) ckalloc(numArgs * sizeof(Tcl_ValueType)); @@ -2981,12 +2977,8 @@ OldMathFuncProc( { Tcl_Obj *valuePtr; OldMathFuncData *dataPtr = clientData; - Tcl_Value args[MAX_MATH_ARGS]; - Tcl_Value funcResult; + Tcl_Value funcResult, *args; int result; -#if 0 - int i; -#endif int j, k; double d; @@ -3003,59 +2995,11 @@ OldMathFuncProc( * Convert arguments from Tcl_Obj's to Tcl_Value's. */ -#if 0 + args = (Tcl_Value *) + TclStackAlloc(interp, dataPtr->numArgs * sizeof(Tcl_Value)); for (j = 1, k = 0; j < objc; ++j, ++k) { - valuePtr = objv[j]; - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Copy the object's numeric value to the argument record, converting - * it if necessary. - */ - if (valuePtr->typePtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - if (dataPtr->argTypes[k] == TCL_DOUBLE) { - args[k].type = TCL_DOUBLE; - args[k].doubleValue = i; - } else if (dataPtr->argTypes[k] == TCL_WIDE_INT) { - args[k].type = TCL_WIDE_INT; - args[k].wideValue = Tcl_LongAsWide(i); - } else { - args[k].type = TCL_INT; - args[k].intValue = i; - } - } else if (valuePtr->typePtr == &tclWideIntType) { - Tcl_WideInt w; - TclGetWide(w,valuePtr); - if (dataPtr->argTypes[k] == TCL_DOUBLE) { - args[k].type = TCL_DOUBLE; - args[k].doubleValue = Tcl_WideAsDouble(w); - } else if (dataPtr->argTypes[k] == TCL_INT) { - args[k].type = TCL_INT; - args[k].intValue = Tcl_WideAsLong(w); - } else { - args[k].type = TCL_WIDE_INT; - args[k].wideValue = w; - } - } else { - d = valuePtr->internalRep.doubleValue; - if (dataPtr->argTypes[k] == TCL_INT) { - args[k].type = TCL_INT; - args[k].intValue = (long) d; - } else if (dataPtr->argTypes[k] == TCL_WIDE_INT) { - args[k].type = TCL_WIDE_INT; - args[k].wideValue = Tcl_DoubleAsWide(d); - } else { - args[k].type = TCL_DOUBLE; - args[k].doubleValue = d; - } - } - } -#else - for (j = 1, k = 0; j < objc; ++j, ++k) { + /* TODO: Convert to TclGetNumberFromObj() ? */ valuePtr = objv[j]; result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); #ifdef ACCEPT_NAN @@ -3072,6 +3016,7 @@ OldMathFuncProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value",-1)); TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); + TclStackFree(interp, args); return TCL_ERROR; } @@ -3103,6 +3048,7 @@ OldMathFuncProc( break; case TCL_INT: if (ExprIntFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { + TclStackFree(interp, args); return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); @@ -3111,6 +3057,7 @@ OldMathFuncProc( break; case TCL_WIDE_INT: if (ExprWideFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { + TclStackFree(interp, args); return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); @@ -3119,7 +3066,6 @@ OldMathFuncProc( break; } } -#endif /* * Call the function. @@ -3127,6 +3073,7 @@ OldMathFuncProc( errno = 0; result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult); + TclStackFree(interp, args); if (result != TCL_OK) { return result; } @@ -3897,7 +3844,7 @@ TclEvalEx( { Interp *iPtr = (Interp *) interp; const char *p, *next; - const int minObjs = 20; + const unsigned int minObjs = 20; Tcl_Obj **objv, **objvSpace; int *expand, *lines, *lineSpace; Tcl_Token *tokenPtr; @@ -4039,7 +3986,7 @@ TclEvalEx( * Generate an array of objects for the words of the command. */ - int objectsNeeded = 0; + unsigned int objectsNeeded = 0; unsigned int numWords = parsePtr->numWords; if (numWords > minObjs) { @@ -4116,12 +4063,11 @@ TclEvalEx( int wordIdx = numWords; int objIdx = objectsNeeded - 1; - if ((numWords > minObjs) - || (objectsNeeded > minObjs)) { + if ((numWords > minObjs) || (objectsNeeded > minObjs)) { objv = objvSpace = (Tcl_Obj **) - ckalloc((unsigned)objectsNeeded*sizeof(Tcl_Obj*)); + ckalloc(objectsNeeded * sizeof(Tcl_Obj*)); lines = lineSpace = (int*) - ckalloc((unsigned) objectsNeeded * sizeof(int)); + ckalloc(objectsNeeded * sizeof(int)); } objectsUsed = 0; @@ -5934,28 +5880,6 @@ ExprDoubleFunc( Tcl_Obj *const *objv) /* Actual parameter vector */ { double dResult; -#if 0 - Tcl_Obj* valuePtr; - Tcl_Obj* oResult; - - /* - * Check parameter type - */ - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - } else { - valuePtr = objv[1]; - if (VerifyExprObjType(interp, valuePtr) == TCL_OK) { - GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr); - TclNewDoubleObj(oResult, dResult); - Tcl_SetObjResult(interp, oResult); - return TCL_OK; - } - } - - return TCL_ERROR; -#else if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; @@ -5971,7 +5895,6 @@ ExprDoubleFunc( } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); return TCL_OK; -#endif } static int @@ -6040,46 +5963,6 @@ ExprIntFunc( { long iResult; Tcl_Obj *objPtr; -#if 0 - register Tcl_Obj *valuePtr; - Tcl_Obj* oResult; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - } else { - valuePtr = objv[1]; - if (VerifyExprObjType(interp, valuePtr) == TCL_OK) { - if (valuePtr->typePtr == &tclIntType) { - iResult = valuePtr->internalRep.longValue; - } else if (valuePtr->typePtr == &tclWideIntType) { - TclGetLongFromWide(iResult,valuePtr); - } else { - d = valuePtr->internalRep.doubleValue; - if (d < 0.0) { - if (d < (double) (long) LONG_MIN) { - tooLarge: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", NULL); - return TCL_ERROR; - } - } else if (d > (double) LONG_MAX) { - goto tooLarge; - } - if (IS_NAN(d) || IS_INF(d)) { - TclExprFloatError(interp, d); - return TCL_ERROR; - } - iResult = (long) d; - } - TclNewIntObj(oResult, iResult); - Tcl_SetObjResult(interp, oResult); - return TCL_OK; - } - } - return TCL_ERROR; -#else if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { return TCL_ERROR; } @@ -6100,7 +5983,6 @@ ExprIntFunc( } Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); return TCL_OK; -#endif } static int @@ -6113,46 +5995,6 @@ ExprWideFunc( { Tcl_WideInt wResult; Tcl_Obj *objPtr; -#if 0 - register Tcl_Obj *valuePtr; - Tcl_Obj *oResult; - - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - } else { - valuePtr = objv[1]; - if (VerifyExprObjType(interp, valuePtr) == TCL_OK) { - if (valuePtr->typePtr == &tclIntType) { - wResult = valuePtr->internalRep.longValue; - } else if (valuePtr->typePtr == &tclWideIntType) { - wResult = valuePtr->internalRep.wideValue; - } else { - d = valuePtr->internalRep.doubleValue; - if (d < 0.0) { - if (d < Tcl_WideAsDouble(LLONG_MIN)) { - tooLarge: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", NULL); - return TCL_ERROR; - } - } else if (d > Tcl_WideAsDouble(LLONG_MAX)) { - goto tooLarge; - } - if (IS_NAN(d) || IS_INF(d)) { - TclExprFloatError(interp, d); - return TCL_ERROR; - } - wResult = (Tcl_WideInt) d; - } - TclNewWideIntObj(oResult, wResult); - Tcl_SetObjResult(interp, oResult); - return TCL_OK; - } - } - return TCL_ERROR; -#else if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { return TCL_ERROR; } @@ -6173,7 +6015,6 @@ ExprWideFunc( } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; -#endif } static int diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 63a0779..4357e6b 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.115.2.4 2007/06/25 18:53:29 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.115.2.5 2007/07/01 17:31:23 dgp Exp $ */ #include "tclInt.h" @@ -1188,7 +1188,8 @@ InfoFrameCmd( * Execution of bytecode. Talk to the BC engine to fill out the frame. */ - Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; + Proc *procPtr = + framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; CmdFrame *fPtr; fPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); @@ -1197,7 +1198,6 @@ InfoFrameCmd( /* * Note: * Type BC => f.data.eval.path is not used. - * f.data.tebc.codePtr is used instead. */ @@ -1221,7 +1221,8 @@ InfoFrameCmd( Tcl_DecrRefCount(fPtr->data.eval.path); } - ADD_PAIR("cmd", Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); + ADD_PAIR("cmd", + Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); if (procPtr != NULL) { Tcl_HashEntry *namePtr = procPtr->cmdPtr->hPtr; @@ -3991,7 +3992,7 @@ Tcl_LsortObjCmd( * 1675116] */ - listObj = TclListObjCopy(interp,listObj); + listObj = TclListObjCopy(interp, listObj); if (listObj == NULL) { if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); @@ -4009,9 +4010,10 @@ Tcl_LsortObjCmd( Tcl_IncrRefCount(newCommandPtr); if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr) != TCL_OK) { - Tcl_DecrRefCount(newCommandPtr); + TclDecrRefCount(newCommandPtr); + TclDecrRefCount(listObj); Tcl_IncrRefCount(newObjPtr); - Tcl_DecrRefCount(newObjPtr); + TclDecrRefCount(newObjPtr); if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } @@ -4070,8 +4072,8 @@ Tcl_LsortObjCmd( done: if (sortInfo.sortMode == SORTMODE_COMMAND) { - Tcl_DecrRefCount(sortInfo.compareCmdPtr); - Tcl_DecrRefCount(listObj); + TclDecrRefCount(sortInfo.compareCmdPtr); + TclDecrRefCount(listObj); sortInfo.compareCmdPtr = NULL; } if (sortInfo.indexc > 1) { diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a131b7c..09a6648 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.109.2.2 2007/06/21 16:04:55 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.3 2007/07/01 17:31:23 dgp Exp $ */ #include "tclInt.h" @@ -1665,7 +1665,7 @@ TclCompileForeachCmd( ckfree((char *) varvList[loopIndex]); } } - TclStackFree(interp, varvList); + TclStackFree(interp, (void *)varvList); TclStackFree(interp, varcList); return code; } diff --git a/generic/tclDate.c b/generic/tclDate.c index 288b5a4..05f6d44 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -1,7 +1,7 @@ -/* A Bison parser, made by GNU Bison 1.875b. */ +/* A Bison parser, made by GNU Bison 1.875e. */ /* Skeleton parser for Yacc-like parsing with Bison, - Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -174,6 +174,9 @@ typedef struct DateInfo { #define YYPARSE_PARAM info #define YYLEX_PARAM info +#define YYMALLOC ckalloc +#define YYFREE ckfree + #define yyDSTmode (((DateInfo *) info)->dateDSTmode) #define yyDayOrdinal (((DateInfo *) info)->dateDayOrdinal) #define yyDayNumber (((DateInfo *) info)->dateDayNumber) @@ -289,18 +292,25 @@ typedef union YYSTYPE { #if ! defined (yyoverflow) || YYERROR_VERBOSE +# ifndef YYFREE +# define YYFREE free +# endif +# ifndef YYMALLOC +# define YYMALLOC malloc +# endif + /* The parser invokes alloca or malloc; define the necessary symbols. */ -# if YYSTACK_USE_ALLOCA -# define YYSTACK_ALLOC alloca +# ifdef YYSTACK_USE_ALLOCA +# if YYSTACK_USE_ALLOCA +# define YYSTACK_ALLOC alloca +# endif # else -# ifndef YYSTACK_USE_ALLOCA -# if defined (alloca) || defined (_ALLOCA_H) -# define YYSTACK_ALLOC alloca -# else -# ifdef __GNUC__ -# define YYSTACK_ALLOC __builtin_alloca -# endif +# if defined (alloca) || defined (_ALLOCA_H) +# define YYSTACK_ALLOC alloca +# else +# ifdef __GNUC__ +# define YYSTACK_ALLOC __builtin_alloca # endif # endif # endif @@ -313,20 +323,20 @@ typedef union YYSTYPE { # include /* INFRINGES ON USER NAME SPACE */ # define YYSIZE_T size_t # endif -# define YYSTACK_ALLOC malloc -# define YYSTACK_FREE free +# define YYSTACK_ALLOC YYMALLOC +# define YYSTACK_FREE YYFREE # endif #endif /* ! defined (yyoverflow) || YYERROR_VERBOSE */ #if (! defined (yyoverflow) \ && (! defined (__cplusplus) \ - || (YYSTYPE_IS_TRIVIAL))) + || (defined (YYSTYPE_IS_TRIVIAL) && YYSTYPE_IS_TRIVIAL))) /* A type that is properly aligned for any stack member. */ union yyalloc { - short yyss; + short int yyss; YYSTYPE yyvs; }; @@ -336,13 +346,13 @@ union yyalloc /* The size of an array large to enough to hold all stacks, each with N elements. */ # define YYSTACK_BYTES(N) \ - ((N) * (sizeof (short) + sizeof (YYSTYPE)) \ + ((N) * (sizeof (short int) + sizeof (YYSTYPE)) \ + YYSTACK_GAP_MAXIMUM) /* Copy COUNT objects from FROM to TO. The source and destination do not overlap. */ # ifndef YYCOPY -# if 1 < __GNUC__ +# if defined (__GNUC__) && 1 < __GNUC__ # define YYCOPY(To, From, Count) \ __builtin_memcpy (To, From, (Count) * sizeof (*(From))) # else @@ -378,7 +388,7 @@ union yyalloc #if defined (__STDC__) || defined (__cplusplus) typedef signed char yysigned_char; #else - typedef short yysigned_char; + typedef short int yysigned_char; #endif /* YYFINAL -- State number of the termination state. */ @@ -472,14 +482,14 @@ static const yysigned_char yyrhs[] = }; /* YYRLINE[YYN] -- source line where rule number YYN was defined. */ -static const unsigned short yyrline[] = +static const unsigned short int yyrline[] = { - 0, 182, 182, 183, 186, 189, 192, 195, 198, 201, - 204, 208, 213, 216, 222, 228, 236, 242, 253, 257, - 261, 267, 271, 275, 279, 283, 289, 293, 298, 303, - 308, 313, 317, 322, 326, 331, 338, 342, 348, 357, - 366, 376, 390, 395, 398, 401, 404, 407, 410, 415, - 418, 423, 427, 431, 437, 455, 458 + 0, 185, 185, 186, 189, 192, 195, 198, 201, 204, + 207, 211, 216, 219, 225, 231, 239, 245, 256, 260, + 264, 270, 274, 278, 282, 286, 292, 296, 301, 306, + 311, 316, 320, 325, 329, 334, 341, 345, 351, 360, + 369, 379, 393, 398, 401, 404, 407, 410, 413, 418, + 421, 426, 430, 434, 440, 458, 461 }; #endif @@ -488,12 +498,12 @@ static const unsigned short yyrline[] = First, the terminals, then, starting at YYNTOKENS, nonterminals. */ static const char *const yytname[] = { - "$end", "error", "$undefined", "tAGO", "tDAY", "tDAYZONE", "tID", - "tMERIDIAN", "tMINUTE_UNIT", "tMONTH", "tMONTH_UNIT", "tSTARDATE", - "tSEC_UNIT", "tSNUMBER", "tUNUMBER", "tZONE", "tEPOCH", "tDST", - "tISOBASE", "tDAY_UNIT", "tNEXT", "':'", "'-'", "','", "'/'", "'.'", - "'+'", "$accept", "spec", "item", "time", "zone", "day", "date", - "ordMonth", "iso", "trek", "relspec", "relunits", "sign", "unit", + "$end", "error", "$undefined", "tAGO", "tDAY", "tDAYZONE", "tID", + "tMERIDIAN", "tMINUTE_UNIT", "tMONTH", "tMONTH_UNIT", "tSTARDATE", + "tSEC_UNIT", "tSNUMBER", "tUNUMBER", "tZONE", "tEPOCH", "tDST", + "tISOBASE", "tDAY_UNIT", "tNEXT", "':'", "'-'", "','", "'/'", "'.'", + "'+'", "$accept", "spec", "item", "time", "zone", "day", "date", + "ordMonth", "iso", "trek", "relspec", "relunits", "sign", "unit", "number", "o_merid", 0 }; #endif @@ -501,7 +511,7 @@ static const char *const yytname[] = # ifdef YYPRINT /* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to token YYLEX-NUM. */ -static const unsigned short yytoknum[] = +static const unsigned short int yytoknum[] = { 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, @@ -644,7 +654,7 @@ static const unsigned char yystos[] = #define YYACCEPT goto yyacceptlab #define YYABORT goto yyabortlab -#define YYERROR goto yyerrlab1 +#define YYERROR goto yyerrorlab /* Like YYERROR except do call yyerror. This remains here temporarily @@ -672,20 +682,50 @@ do \ } \ while (0) + #define YYTERROR 1 #define YYERRCODE 256 -/* YYLLOC_DEFAULT -- Compute the default location (before the actions - are run). */ + +/* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N]. + If N is 0, then set CURRENT to the empty location which ends + the previous symbol: RHS[0] (always defined). */ #ifndef YYLLOC_DEFAULT -# define YYLLOC_DEFAULT(Current, Rhs, N) \ - Current.first_line = Rhs[1].first_line; \ - Current.first_column = Rhs[1].first_column; \ - Current.last_line = Rhs[N].last_line; \ - Current.last_column = Rhs[N].last_column; +# define YYLLOC_DEFAULT(Current, Rhs, N) \ +do { \ + if (N) \ + { \ + (Current).first_line = (Rhs)[1].first_line; \ + (Current).first_column = (Rhs)[1].first_column; \ + (Current).last_line = (Rhs)[N].last_line; \ + (Current).last_column = (Rhs)[N].last_column; \ + } \ + else \ + { \ + (Current).first_line = (Current).last_line = (Rhs)[0].last_line; \ + (Current).first_column = (Current).last_column = (Rhs)[0].last_column; \ + } \ +} while(0) +#endif + + +/* YY_LOCATION_PRINT -- Print the location on the stream. + This macro was not mandated originally: define only if we know + we won't break user code: when these are the locations we know. */ + +#ifndef YY_LOCATION_PRINT +# if YYLTYPE_IS_TRIVIAL +# define YY_LOCATION_PRINT(File, Loc) \ + fprintf (File, "%d.%d-%d.%d", \ + (Loc).first_line, (Loc).first_column, \ + (Loc).last_line, (Loc).last_column) +# else +# define YY_LOCATION_PRINT(File, Loc) ((void) 0) +# endif #endif + /* YYLEX -- calling `yylex' with the right arguments. */ #ifdef YYLEX_PARAM @@ -708,36 +748,30 @@ do { \ YYFPRINTF Args; \ } while (0) -# define YYDSYMPRINT(Args) \ -do { \ - if (yydebug) \ - yysymprint Args; \ -} while (0) - -# define YYDSYMPRINTF(Title, Token, Value, Location) \ +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ do { \ if (yydebug) \ { \ YYFPRINTF (stderr, "%s ", Title); \ yysymprint (stderr, \ - Token, Value); \ + Type, Value); \ YYFPRINTF (stderr, "\n"); \ } \ } while (0) /*------------------------------------------------------------------. | yy_stack_print -- Print the state stack from its BOTTOM up to its | -| TOP (cinluded). | +| TOP (included). | `------------------------------------------------------------------*/ #if defined (__STDC__) || defined (__cplusplus) static void -yy_stack_print (short *bottom, short *top) +yy_stack_print (short int *bottom, short int *top) #else static void yy_stack_print (bottom, top) - short *bottom; - short *top; + short int *bottom; + short int *top; #endif { YYFPRINTF (stderr, "Stack now"); @@ -787,8 +821,7 @@ do { \ int yydebug; #else /* !YYDEBUG */ # define YYDPRINTF(Args) -# define YYDSYMPRINT(Args) -# define YYDSYMPRINTF(Title, Token, Value, Location) +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) # define YY_STACK_PRINT(Bottom, Top) # define YY_REDUCE_PRINT(Rule) #endif /* !YYDEBUG */ @@ -806,7 +839,7 @@ int yydebug; SIZE_MAX < YYSTACK_BYTES (YYMAXDEPTH) evaluated with infinite-precision integer arithmetic. */ -#if YYMAXDEPTH == 0 +#if defined (YYMAXDEPTH) && YYMAXDEPTH == 0 # undef YYMAXDEPTH #endif @@ -891,15 +924,15 @@ yysymprint (yyoutput, yytype, yyvaluep) (void) yyvaluep; if (yytype < YYNTOKENS) - { - YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); -# ifdef YYPRINT - YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); -# endif - } + YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); else YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); + +# ifdef YYPRINT + if (yytype < YYNTOKENS) + YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); +# endif switch (yytype) { default: @@ -915,10 +948,11 @@ yysymprint (yyoutput, yytype, yyvaluep) #if defined (__STDC__) || defined (__cplusplus) static void -yydestruct (int yytype, YYSTYPE *yyvaluep) +yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep) #else static void -yydestruct (yytype, yyvaluep) +yydestruct (yymsg, yytype, yyvaluep) + const char *yymsg; int yytype; YYSTYPE *yyvaluep; #endif @@ -926,6 +960,10 @@ yydestruct (yytype, yyvaluep) /* Pacify ``unused variable'' warnings. */ (void) yyvaluep; + if (!yymsg) + yymsg = "Deleting"; + YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); + switch (yytype) { @@ -953,10 +991,10 @@ int yyparse (); -/* The lookahead symbol. */ +/* The look-ahead symbol. */ int yychar; -/* The semantic value of the lookahead symbol. */ +/* The semantic value of the look-ahead symbol. */ YYSTYPE yylval; /* Number of syntax errors so far. */ @@ -992,7 +1030,7 @@ yyparse () int yyresult; /* Number of tokens to shift before error messages enabled. */ int yyerrstatus; - /* Lookahead token as an internal (translated) token number. */ + /* Look-ahead token as an internal (translated) token number. */ int yytoken = 0; /* Three stacks and their tools: @@ -1004,9 +1042,9 @@ yyparse () to reallocate them elsewhere. */ /* The state stack. */ - short yyssa[YYINITDEPTH]; - short *yyss = yyssa; - register short *yyssp; + short int yyssa[YYINITDEPTH]; + short int *yyss = yyssa; + register short int *yyssp; /* The semantic value stack. */ YYSTYPE yyvsa[YYINITDEPTH]; @@ -1043,6 +1081,9 @@ yyparse () yyssp = yyss; yyvsp = yyvs; + + yyvsp[0] = yylval; + goto yysetstate; /*------------------------------------------------------------. @@ -1068,7 +1109,7 @@ yyparse () these so that the &'s don't force the real ones into memory. */ YYSTYPE *yyvs1 = yyvs; - short *yyss1 = yyss; + short int *yyss1 = yyss; /* Each stack pointer address is followed by the size of the @@ -1096,7 +1137,7 @@ yyparse () yystacksize = YYMAXDEPTH; { - short *yyss1 = yyss; + short int *yyss1 = yyss; union yyalloc *yyptr = (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); if (! yyptr) @@ -1132,18 +1173,18 @@ yyparse () yybackup: /* Do appropriate processing given the current state. */ -/* Read a lookahead token if we need one and don't already have one. */ +/* Read a look-ahead token if we need one and don't already have one. */ /* yyresume: */ - /* First try to decide what to do without reference to lookahead token. */ + /* First try to decide what to do without reference to look-ahead token. */ yyn = yypact[yystate]; if (yyn == YYPACT_NINF) goto yydefault; - /* Not known => get a lookahead token if don't already have one. */ + /* Not known => get a look-ahead token if don't already have one. */ - /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ + /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */ if (yychar == YYEMPTY) { YYDPRINTF ((stderr, "Reading a token: ")); @@ -1158,7 +1199,7 @@ yybackup: else { yytoken = YYTRANSLATE (yychar); - YYDSYMPRINTF ("Next token is", yytoken, &yylval, &yylloc); + YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc); } /* If the proper action on seeing token YYTOKEN is to reduce or to @@ -1178,8 +1219,8 @@ yybackup: if (yyn == YYFINAL) YYACCEPT; - /* Shift the lookahead token. */ - YYDPRINTF ((stderr, "Shifting token %s, ", yytname[yytoken])); + /* Shift the look-ahead token. */ + YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); /* Discard the token being shifted unless it is eof. */ if (yychar != YYEOF) @@ -1682,7 +1723,7 @@ yyreduce: } -/* Line 999 of yacc.c. */ +/* Line 1043 of yacc.c. */ yyvsp -= yylen; @@ -1783,38 +1824,57 @@ yyerrlab: if (yyerrstatus == 3) { - /* If just tried and failed to reuse lookahead token after an + /* If just tried and failed to reuse look-ahead token after an error, discard it. */ - /* Return failure if at end of input. */ - if (yychar == YYEOF) + if (yychar <= YYEOF) { - /* Pop the error token. */ - YYPOPSTACK; - /* Pop the rest of the stack. */ - while (yyss < yyssp) - { - YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp, yylsp); - yydestruct (yystos[*yyssp], yyvsp); - YYPOPSTACK; - } - YYABORT; + /* If at end of input, pop the error token, + then the rest of the stack, then return failure. */ + if (yychar == YYEOF) + for (;;) + { + + YYPOPSTACK; + if (yyssp == yyss) + YYABORT; + yydestruct ("Error: popping", + yystos[*yyssp], yyvsp); + } } - - YYDSYMPRINTF ("Error: discarding", yytoken, &yylval, &yylloc); - yydestruct (yytoken, &yylval); - yychar = YYEMPTY; - + else + { + yydestruct ("Error: discarding", yytoken, &yylval); + yychar = YYEMPTY; + } } - /* Else will try to reuse lookahead token after shifting the error + /* Else will try to reuse look-ahead token after shifting the error token. */ goto yyerrlab1; -/*----------------------------------------------------. -| yyerrlab1 -- error raised explicitly by an action. | -`----------------------------------------------------*/ +/*---------------------------------------------------. +| yyerrorlab -- error raised explicitly by YYERROR. | +`---------------------------------------------------*/ +yyerrorlab: + +#ifdef __GNUC__ + /* Pacify GCC when the user code never invokes YYERROR and the label + yyerrorlab therefore never appears in user code. */ + if (0) + goto yyerrorlab; +#endif + +yyvsp -= yylen; + yyssp -= yylen; + yystate = *yyssp; + goto yyerrlab1; + + +/*-------------------------------------------------------------. +| yyerrlab1 -- common code for both syntax error and YYERROR. | +`-------------------------------------------------------------*/ yyerrlab1: yyerrstatus = 3; /* Each real token shifted decrements this. */ @@ -1836,22 +1896,22 @@ yyerrlab1: if (yyssp == yyss) YYABORT; - YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp, yylsp); - yydestruct (yystos[yystate], yyvsp); - yyvsp--; - yystate = *--yyssp; + yydestruct ("Error: popping", yystos[yystate], yyvsp); + YYPOPSTACK; + yystate = *yyssp; YY_STACK_PRINT (yyss, yyssp); } if (yyn == YYFINAL) YYACCEPT; - YYDPRINTF ((stderr, "Shifting error token, ")); - *++yyvsp = yylval; + /* Shift the error token. */ + YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp); + yystate = yyn; goto yynewstate; @@ -1867,6 +1927,9 @@ yyacceptlab: | yyabortlab -- YYABORT comes here. | `-----------------------------------*/ yyabortlab: + yydestruct ("Error: discarding lookahead", + yytoken, &yylval); + yychar = YYEMPTY; yyresult = 1; goto yyreturn; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index eb6096f..8a05056 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.285.2.10 2007/06/27 01:37:43 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.285.2.11 2007/07/01 17:31:23 dgp Exp $ */ #include "tclInt.h" @@ -4949,242 +4949,6 @@ TclExecuteByteCode( } } -#if 0 -/* - * Macro to read a string containing either a wide or an int and decide which - * it is while decoding it at the same time. This enforces the policy that - * integer constants between LONG_MIN and LONG_MAX (inclusive) are represented - * by normal longs, and integer constants outside that range are represented - * by wide ints. - */ - -#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ - (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \ - if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ - && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ - (objPtr)->typePtr = &tclIntType; \ - (objPtr)->internalRep.longValue = (longVar) \ - = Tcl_WideAsLong(wideVar); \ - } - -#define W0 Tcl_LongAsWide(0) -/* - * For tracing that uses wide values. - */ -#define LLD "%" TCL_LL_MODIFIER "d" - case INST_MOD: { - /* - * Only integers are allowed. We compute value op value2. - */ - - long i = 0, i2 = 0, rem, neg_divisor = 0; - long iResult = 0; /* Init. avoids compiler warning. */ - Tcl_WideInt w, w2, wResult = W0; - int doWide = 0; - Tcl_Obj *valuePtr, *value2Ptr; - - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - if (valuePtr->typePtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else if (valuePtr->typePtr == &tclWideIntType) { - TclGetWide(w,valuePtr); - } else { /* try to convert to int */ - REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); - if (result != TCL_OK) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(valuePtr), O2S(value2Ptr), - (valuePtr->typePtr? - valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; - } - } - if (value2Ptr->typePtr == &tclIntType) { - i2 = value2Ptr->internalRep.longValue; - } else if (value2Ptr->typePtr == &tclWideIntType) { - TclGetWide(w2,value2Ptr); - } else { - REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2); - if (result != TCL_OK) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(valuePtr), O2S(value2Ptr), - (value2Ptr->typePtr? - value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - goto checkForCatch; - } - } - - do { - /* - * This code is tricky: C doesn't guarantee much about the - * quotient or remainder, and results with a negative divisor are - * not specified. Tcl guarantees that the remainder will have the - * same sign as the divisor and a smaller absolute value. - */ - - if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) { - if (valuePtr->typePtr == &tclIntType) { - TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2)); - } else { - TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); - } - goto divideByZero; - } - if (value2Ptr->typePtr == &tclIntType && i2 == 0) { - if (valuePtr->typePtr == &tclIntType) { - TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); - } else { - TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2)); - } - goto divideByZero; - } - if (valuePtr->typePtr == &tclWideIntType - || value2Ptr->typePtr == &tclWideIntType) { - Tcl_WideInt wRemainder; - - /* - * Promote to wide - */ - - if (valuePtr->typePtr == &tclIntType) { - w = Tcl_LongAsWide(i); - } else if (value2Ptr->typePtr == &tclIntType) { - w2 = Tcl_LongAsWide(i2); - } - if (w == LLONG_MIN && w2 == -1) { - /* - * Integer overflow could happen with (LLONG_MIN % -1) - * even though it is not possible in the code below. - */ - - wRemainder = 0; - } else if (w == LLONG_MIN && w2 == LLONG_MAX) { - wRemainder = LLONG_MAX - 1; - } else if (w2 == LLONG_MIN) { - /* - * In C, a modulus operation is not well defined when the - * divisor is a negative number. So w % LLONG_MIN is not - * well defined in the code below because -LLONG_MIN is - * still a negative number. - */ - - if (w == 0 || w == LLONG_MIN) { - wRemainder = 0; - } else if (w < 0) { - wRemainder = w; - } else { - wRemainder = LLONG_MIN + w; - } - neg_divisor = 1; - } else { - if (w2 < 0) { - w2 = -w2; - w = -w; /* Note: -LLONG_MIN == LLONG_MIN */ - neg_divisor = 1; - } - wRemainder = w % w2; - - /* - * remainder is (remainder + divisor) when the remainder - * is negative. Watch out for the special case of a - * LLONG_MIN dividend and a negative divisor. Don't add - * the divisor in that case because the remainder should - * not be negative. - */ - - if (wRemainder < 0 && !(neg_divisor && w==LLONG_MIN)) { - wRemainder += w2; - } - } - if ((neg_divisor && (wRemainder > 0)) || - (!neg_divisor && (wRemainder < 0))) { - wRemainder = -wRemainder; - } - wResult = wRemainder; - doWide = 1; - break; - } - - if (i == LONG_MIN && i2 == -1) { - /* - * Integer overflow could happen with (LONG_MIN % -1) even - * though it is not possible in the code below. - */ - - rem = 0; - } else if (i == LONG_MIN && i2 == LONG_MAX) { - rem = LONG_MAX - 1; - } else if (i2 == LONG_MIN) { - /* - * In C, a modulus operation is not well defined when the - * divisor is a negative number. So i % LONG_MIN is not well - * defined in the code below because -LONG_MIN is still a - * negative number. - */ - - if (i == 0 || i == LONG_MIN) { - rem = 0; - } else if (i < 0) { - rem = i; - } else { - rem = LONG_MIN + i; - } - neg_divisor = 1; - } else { - if (i2 < 0) { - i2 = -i2; - i = -i; /* Note: -LONG_MIN == LONG_MIN */ - neg_divisor = 1; - } - rem = i % i2; - - /* - * Remainder is (remainder + divisor) when the remainder is - * negative. Watch out for the special case of a LONG_MIN - * dividend and a negative divisor. Don't add the divisor in - * that case because the remainder should not be negative. - */ - - if (rem < 0 && !(neg_divisor && (i == LONG_MIN))) { - rem += i2; - } - } - - if ((neg_divisor && (rem > 0)) || - (!neg_divisor && (rem < 0))) { - rem = -rem; - } - iResult = rem; - } while (0); - - /* - * Reuse the valuePtr object already on stack if possible. - */ - - if (Tcl_IsShared(valuePtr)) { - if (doWide) { - TclNewWideIntObj(objResultPtr, wResult); - TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); - } else { - TclNewLongObj(objResultPtr, iResult); - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - } - NEXT_INST_F(1, 2, 1); - } else { /* reuse the valuePtr object */ - if (doWide) { - TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); - TclSetWideIntObj(valuePtr, wResult); - } else { - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - TclSetLongObj(valuePtr, iResult); - } - NEXT_INST_F(1, 1, 0); - } - } -#endif - case INST_EXPON: case INST_ADD: case INST_SUB: diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index f6dfa26..53e611f 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.39.2.1 2007/06/21 16:04:56 dgp Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.39.2.2 2007/07/01 17:31:24 dgp Exp $ */ #include "tclInt.h" @@ -1112,7 +1112,7 @@ TclFileAttrsCmd( * Free up the array we allocated. */ - TclStackFree(interp, attributeStrings); + TclStackFree(interp, (void *)attributeStrings); /* * We don't need this object that was passed to us any more. diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 607c8ae..9890168 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -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: tclGetDate.y,v 1.35 2007/04/20 05:51:10 kennykb Exp $ + * RCS: @(#) $Id: tclGetDate.y,v 1.35.2.1 2007/07/01 17:31:24 dgp Exp $ */ %{ @@ -84,6 +84,9 @@ typedef struct DateInfo { #define YYPARSE_PARAM info #define YYLEX_PARAM info +#define YYMALLOC ckalloc +#define YYFREE ckfree + #define yyDSTmode (((DateInfo *) info)->dateDSTmode) #define yyDayOrdinal (((DateInfo *) info)->dateDayOrdinal) #define yyDayNumber (((DateInfo *) info)->dateDayNumber) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index be23aa4..963d18e 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.40.2.1 2007/06/21 16:04:56 dgp Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.40.2.2 2007/07/01 17:31:24 dgp Exp $ */ #include "tclInt.h" @@ -872,7 +872,7 @@ Tcl_ExecObjCmd( * Free the argv array. */ - TclStackFree(interp, argv); + TclStackFree(interp, (void *)argv); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; diff --git a/generic/tclInt.h b/generic/tclInt.h index 3152e3c..77f805b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.310.2.5 2007/06/25 18:53:31 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.310.2.6 2007/07/01 17:31:24 dgp Exp $ */ #ifndef _TCLINT @@ -1109,36 +1109,6 @@ typedef void **TclHandle; * string. */ /* - *---------------------------------------------------------------- - * Data structures related to expressions. - *---------------------------------------------------------------- - */ - -/* - * The data structure below defines a math function (e.g. sin or hypot) for - * use in Tcl expressions. - */ - -#define MAX_MATH_ARGS 5 -typedef struct MathFunc { - int builtinFuncIndex; /* If this is a builtin math function, its - * index in the array of builtin functions. - * (tclCompilation.h lists these indices.) - * The value is -1 if this is a new function - * defined by Tcl_CreateMathFunc. The value is - * also -1 if a builtin function is replaced - * by a Tcl_CreateMathFunc call. */ - int numArgs; /* Number of arguments for function. */ - Tcl_ValueType argTypes[MAX_MATH_ARGS]; - /* Acceptable types for each argument. */ - Tcl_MathProc *proc; /* Procedure that implements this function. - * NULL if isBuiltinFunc is 1. */ - ClientData clientData; /* Additional argument to pass to the function - * when invoking it. NULL if isBuiltinFunc is - * 1. */ -} MathFunc; - -/* * These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet * when threads are used, or an emulation if there are no threads. These are * really internal and Tcl clients should use Tcl_GetThreadData. @@ -1539,10 +1509,7 @@ typedef struct Interp { ClientData interpInfo; /* Information used by tclInterp.c to keep * track of master/slave interps on a * per-interp basis. */ - Tcl_HashTable mathFuncTable;/* Contains all the math functions currently - * defined for the interpreter. Indexed by - * strings (function names); values have type - * (MathFunc *). */ + Tcl_HashTable unused2; /* No longer used (was mathFuncTable) */ /* * Information related to procedures and variables. See tclProc.c and diff --git a/generic/tclMathOp.c b/generic/tclMathOp.c deleted file mode 100644 index 9858c00..0000000 --- a/generic/tclMathOp.c +++ /dev/null @@ -1,2884 +0,0 @@ -/* - * tclMathOp.c -- - * - * This file contains normal command versions of the contents of the - * tcl::mathop namespace. - * - * Copyright (c) 2006 by Donal K. Fellows. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclMathOp.c,v 1.8 2006/12/12 17:21:42 dgp Exp $ - */ - -/* - * NOTE: None of the routines in this file are currently in use. - * The file itself may be removed, but remains in place for now in - * case its routine may be useful during performance testing. - */ - -#if 0 - -#include "tclInt.h" -#include "tclCompile.h" -#include "tommath.h" -#include -#include - -/* - * Hack to determine whether we may expect IEEE floating point. The hack is - * formally incorrect in that non-IEEE platforms might have the same precision - * and range, but VAX, IBM, and Cray do not; are there any other floating - * point units that we might care about? - */ - -#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) -#define IEEE_FLOATING_POINT -#endif - -/* - * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX. - * TODO: Does this serve any purpose anymore? - */ - -#ifdef TCL_GENERIC_ONLY -# ifndef NO_FLOAT_H -# include -# else /* NO_FLOAT_H */ -# ifndef NO_VALUES_H -# include -# endif /* !NO_VALUES_H */ -# endif /* !NO_FLOAT_H */ -#endif /* !TCL_GENERIC_ONLY */ - -/* - * Prototypes for helper functions defined in this file: - */ - -static Tcl_Obj * CombineIntFloat(Tcl_Interp *interp, Tcl_Obj *valuePtr, - int opcode, Tcl_Obj *value2Ptr); -static Tcl_Obj * CombineIntOnly(Tcl_Interp *interp, Tcl_Obj *valuePtr, - int opcode, Tcl_Obj *value2Ptr); -static int CompareNumbers(Tcl_Interp *interp, Tcl_Obj *numObj1, - Tcl_Obj *numObj2, int *resultPtr); - -/* - *---------------------------------------------------------------------- - * - * CombineIntFloat -- - * - * Parses and combines two numbers (either entier() or double()) - * according to the specified operation. - * - * Results: - * Returns the resulting number object (or NULL on failure). - * - * Side effects: - * None. - * - * Notes: - * This code originally extracted from tclExecute.c. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -CombineIntFloat( - Tcl_Interp *interp, /* Place to write error messages. */ - Tcl_Obj *valuePtr, /* First value to combine. */ - int opcode, /* Operation to use to combine the - * values. Must be one of INST_ADD, INST_SUB, - * INST_MULT, INST_DIV or INST_EXPON. */ - Tcl_Obj *value2Ptr) /* Second value to combine. */ -{ - ClientData ptr1, ptr2; - int type1, type2; - Tcl_Obj *errPtr; - - if ((TclGetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) -#ifndef ACCEPT_NAN - || (type1 == TCL_NUMBER_NAN) -#endif - ) { - errPtr = valuePtr; - goto illegalOperand; - } - -#ifdef ACCEPT_NAN - if (type1 == TCL_NUMBER_NAN) { - /* NaN first argument -> result is also NaN */ - NEXT_INST_F(1, 1, 0); - } -#endif - - if ((TclGetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) -#ifndef ACCEPT_NAN - || (type2 == TCL_NUMBER_NAN) -#endif - ) { - errPtr = value2Ptr; - goto illegalOperand; - } - -#ifdef ACCEPT_NAN - if (type2 == TCL_NUMBER_NAN) { - /* NaN second argument -> result is also NaN */ - return value2Ptr; - NEXT_INST_F(1, 2, 1); - } -#endif - - if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { - /* - * At least one of the values is floating-point, so perform floating - * point calculations. - */ - - double d1, d2, dResult; - Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); - Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); - - switch (opcode) { - case INST_ADD: - dResult = d1 + d2; - break; - case INST_SUB: - dResult = d1 - d2; - break; - case INST_MULT: - dResult = d1 * d2; - break; - case INST_DIV: -#ifndef IEEE_FLOATING_POINT - if (d2 == 0.0) { - goto divideByZero; - } -#endif - /* - * We presume that we are running with zero-divide unmasked if - * we're on an IEEE box. Otherwise, this statement might cause - * demons to fly out our noses. - */ - - dResult = d1 / d2; - break; - case INST_EXPON: - if (d1==0.0 && d2<0.0) { - goto exponOfZero; - } - dResult = pow(d1, d2); - break; - default: - /* Unused, here to silence compiler warning. */ - dResult = 0; - } - -#ifndef ACCEPT_NAN - /* - * Check now for IEEE floating-point error. - */ - - if (TclIsNaN(dResult)) { - TclExprFloatError(interp, dResult); - return NULL; - } -#endif - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewDoubleObj(dResult); - } - Tcl_SetDoubleObj(valuePtr, dResult); - return valuePtr; - } - - if ((sizeof(long) >= 2*sizeof(int)) && (opcode == INST_MULT) - && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - long l1 = *((CONST long *)ptr1); - long l2 = *((CONST long *)ptr2); - if ((l1 <= INT_MAX) && (l1 >= INT_MIN) - && (l2 <= INT_MAX) && (l2 >= INT_MIN)) { - long lResult = l1 * l2; - - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewLongObj(lResult); - } - Tcl_SetLongObj(valuePtr, lResult); - return valuePtr; - } - } - - if ((sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (opcode == INST_MULT) - && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - Tcl_WideInt w1, w2, wResult; - Tcl_GetWideIntFromObj(NULL, valuePtr, &w1); - Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); - - wResult = w1 * w2; - - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewWideIntObj(wResult); - } - Tcl_SetWideIntObj(valuePtr, wResult); - return valuePtr; - } - - /* TODO: Attempts to re-use unshared operands on stack */ - if (opcode == INST_EXPON) { - long l1, l2 = 0; - int oddExponent = 0, negativeExponent = 0; - if (type2 == TCL_NUMBER_LONG) { - l2 = *((CONST long *)ptr2); - if (l2 == 0) { - /* Anything to the zero power is 1 */ - return Tcl_NewIntObj(1); - } - } - switch (type2) { - case TCL_NUMBER_LONG: { - negativeExponent = (l2 < 0); - oddExponent = (int) (l2 & 1); - break; - } -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: { - Tcl_WideInt w2 = *((CONST Tcl_WideInt *)ptr2); - negativeExponent = (w2 < 0); - oddExponent = (int) (w2 & (Tcl_WideInt)1); - break; - } -#endif - case TCL_NUMBER_BIG: { - mp_int big2; - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); - mp_mod_2d(&big2, 1, &big2); - oddExponent = !mp_iszero(&big2); - mp_clear(&big2); - break; - } - } - - if (negativeExponent) { - if (type1 == TCL_NUMBER_LONG) { - l1 = *((CONST long *)ptr1); - switch (l1) { - case 0: - /* zero to a negative power is div by zero error */ - goto exponOfZero; - case -1: - if (oddExponent) { - return Tcl_NewIntObj(-1); - } else { - return Tcl_NewIntObj(1); - } - case 1: - /* 1 to any power is 1 */ - return Tcl_NewIntObj(1); - } - } - /* - * Integers with magnitude greater than 1 raise to a negative - * power yield the answer zero (see TIP 123) - */ - return Tcl_NewIntObj(0); - } - - if (type1 == TCL_NUMBER_LONG) { - l1 = *((CONST long *)ptr1); - switch (l1) { - case 0: - /* zero to a positive power is zero */ - return Tcl_NewIntObj(0); - case 1: - /* 1 to any power is 1 */ - return Tcl_NewIntObj(1); - case -1: - if (oddExponent) { - return Tcl_NewIntObj(-1); - } else { - return Tcl_NewIntObj(1); - } - } - } - if (type2 == TCL_NUMBER_BIG) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("exponent too large", -1)); - return NULL; - } - /* TODO: Perform those computations that fit in native types */ - goto overflow; - } - - if ((opcode != INST_MULT) - && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { - Tcl_WideInt w1, w2, wResult; - Tcl_GetWideIntFromObj(NULL, valuePtr, &w1); - Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); - - switch (opcode) { - case INST_ADD: - wResult = w1 + w2; -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif - { - /* Check for overflow */ - if (((w1 < 0) && (w2 < 0) && (wResult >= 0)) - || ((w1 > 0) && (w2 > 0) && (wResult < 0))) { - goto overflow; - } - } - break; - - case INST_SUB: - wResult = w1 - w2; -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif - { - /* Must check for overflow */ - if (((w1 < 0) && (w2 > 0) && (wResult > 0)) - || ((w1 >= 0) && (w2 < 0) && (wResult < 0))) { - goto overflow; - } - } - break; - - case INST_DIV: - if (w2 == 0) { - goto divideByZero; - } - - /* Need a bignum to represent (LLONG_MIN / -1) */ - if ((w1 == LLONG_MIN) && (w2 == -1)) { - goto overflow; - } - wResult = w1 / w2; - - /* Force Tcl's integer division rules */ - /* TODO: examine for logic simplification */ - if (((wResult < 0) || ((wResult == 0) && - ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && - ((wResult * w2) != w1)) { - wResult -= 1; - } - break; - default: - /* Unused, here to silence compiler warning. */ - wResult = 0; - } - - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewWideIntObj(wResult); - } - Tcl_SetWideIntObj(valuePtr, wResult); - return valuePtr; - } - - overflow: - { - mp_int big1, big2, bigResult, bigRemainder; - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); - switch (opcode) { - case INST_ADD: - mp_add(&big1, &big2, &bigResult); - break; - case INST_SUB: - mp_sub(&big1, &big2, &bigResult); - break; - case INST_MULT: - mp_mul(&big1, &big2, &bigResult); - break; - case INST_DIV: - if (mp_iszero(&big2)) { - mp_clear(&big1); - mp_clear(&big2); - goto divideByZero; - } - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); - /* TODO: internals intrusion */ - if (!mp_iszero(&bigRemainder) - && (bigRemainder.sign != big2.sign)) { - /* Convert to Tcl's integer division rules */ - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); - } - mp_clear(&bigRemainder); - break; - case INST_EXPON: - if (big2.used > 1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("exponent too large", -1)); - mp_clear(&big1); - mp_clear(&big2); - return NULL; - } - mp_expt_d(&big1, big2.dp[0], &bigResult); - break; - } - mp_clear(&big1); - mp_clear(&big2); - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewBignumObj(&bigResult); - } - Tcl_SetBignumObj(valuePtr, &bigResult); - return valuePtr; - } - - { - const char *description, *operator; - - illegalOperand: - switch (opcode) { - case INST_ADD: operator = "+"; break; - case INST_SUB: operator = "-"; break; - case INST_MULT: operator = "*"; break; - case INST_DIV: operator = "/"; break; - case INST_EXPON: operator = "**"; break; - default: - operator = "???"; - } - - if (TclGetNumberFromObj(NULL, errPtr, &ptr1, &type1) != TCL_OK) { - int numBytes; - CONST char *bytes = Tcl_GetStringFromObj(errPtr, &numBytes); - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } - } else if (type1 == TCL_NUMBER_NAN) { - description = "non-numeric floating-point value"; - } else if (type1 == TCL_NUMBER_DOUBLE) { - description = "floating-point value"; - } else { - /* TODO: No caller needs this. Eliminate? */ - description = "(big) integer"; - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"%s\"", description, operator)); - return NULL; - } - - divideByZero: - Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); - return NULL; - - exponOfZero: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "exponentiation of zero by negative power", -1)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "exponentiation of zero by negative power", NULL); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * CombineIntOnly -- - * - * Parses and combines two numbers (must be entier()) according to the - * specified operation. - * - * Results: - * Returns the resulting number object (or NULL on failure). - * - * Side effects: - * None. - * - * Notes: - * This code originally extracted from tclExecute.c. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -CombineIntOnly( - Tcl_Interp *interp, /* Place to write error messages. */ - Tcl_Obj *valuePtr, /* First value to combine. */ - int opcode, /* Operation to use to combine the - * values. Must be one of INST_BITAND, - * INST_BITOR or INST_BITXOR. */ - Tcl_Obj *value2Ptr) /* Second value to combine. */ -{ - ClientData ptr1, ptr2; - int type1, type2; - Tcl_Obj *errPtr; - - if ((TclGetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || (type1 == TCL_NUMBER_NAN) || (type1 == TCL_NUMBER_DOUBLE)) { - errPtr = valuePtr; - goto illegalOperand; - } - if ((TclGetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) - || (type2 == TCL_NUMBER_NAN) || (type2 == TCL_NUMBER_DOUBLE)) { - errPtr = value2Ptr; - goto illegalOperand; - } - - if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { - mp_int big1, big2, bigResult; - mp_int *First, *Second; - int numPos; - - - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - - /* - * Count how many positive arguments we have. If only one of the - * arguments is negative, store it in 'Second'. - */ - - if (mp_cmp_d(&big1, 0) != MP_LT) { - numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT); - First = &big1; - Second = &big2; - } else { - First = &big2; - Second = &big1; - numPos = (mp_cmp_d(First, 0) != MP_LT); - } - mp_init(&bigResult); - - switch (opcode) { - case INST_BITAND: - switch (numPos) { - case 2: - /* Both arguments positive, base case */ - mp_and(First, Second, &bigResult); - break; - case 1: - /* First is positive; Second negative - * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) */ - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_and(First, &bigResult, &bigResult); - break; - case 0: - /* Both arguments negative - * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 */ - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_or(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - } - break; - - case INST_BITOR: - switch (numPos) { - case 2: - /* Both arguments positive, base case */ - mp_or(First, Second, &bigResult); - break; - case 1: - /* First is positive; Second negative - * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 */ - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_and(Second, &bigResult, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - case 0: - /* Both arguments negative - * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 */ - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_and(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - } - break; - - case INST_BITXOR: - switch (numPos) { - case 2: - /* Both arguments positive, base case */ - mp_xor(First, Second, &bigResult); - break; - case 1: - /* First is positive; Second negative - * P^N = ~(P^~N) = -(P^(-N-1))-1 */ - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - case 0: - /* Both arguments negative - * a ^ b = (~a ^ ~b) = (-a-1^-b-1) */ - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - break; - } - break; - } - - mp_clear(&big1); - mp_clear(&big2); - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewBignumObj(&bigResult); - } - Tcl_SetBignumObj(valuePtr, &bigResult); - return valuePtr; - } -#ifndef NO_WIDE_TYPE - else if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { - Tcl_WideInt wResult, w1, w2; - Tcl_GetWideIntFromObj(NULL, valuePtr, &w1); - Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); - - switch (opcode) { - case INST_BITAND: - wResult = w1 & w2; - break; - case INST_BITOR: - wResult = w1 | w2; - break; - case INST_BITXOR: - wResult = w1 ^ w2; - break; - default: - /* Unused, here to silence compiler warning. */ - wResult = 0; - } - - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewWideIntObj(wResult); - } - Tcl_SetWideIntObj(valuePtr, wResult); - return valuePtr; - } -#endif - else { - long lResult, l1 = *((const long *)ptr1); - long l2 = *((const long *)ptr2); - - switch (opcode) { - case INST_BITAND: - lResult = l1 & l2; - break; - case INST_BITOR: - lResult = l1 | l2; - break; - case INST_BITXOR: - lResult = l1 ^ l2; - break; - default: - /* Unused, here to silence compiler warning. */ - lResult = 0; - } - - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewLongObj(lResult); - } - TclSetLongObj(valuePtr, lResult); - return valuePtr; - } - - { - const char *description, *operator; - - illegalOperand: - switch (opcode) { - case INST_BITAND: operator = "&"; break; - case INST_BITOR: operator = "|"; break; - case INST_BITXOR: operator = "^"; break; - default: - operator = "???"; - } - - if (TclGetNumberFromObj(NULL, errPtr, &ptr1, &type1) != TCL_OK) { - int numBytes; - CONST char *bytes = Tcl_GetStringFromObj(errPtr, &numBytes); - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } - } else if (type1 == TCL_NUMBER_NAN) { - description = "non-numeric floating-point value"; - } else if (type1 == TCL_NUMBER_DOUBLE) { - description = "floating-point value"; - } else { - /* TODO: No caller needs this. Eliminate? */ - description = "(big) integer"; - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"%s\"", description, operator)); - return NULL; - } -} - -/* - *---------------------------------------------------------------------- - * - * CompareNumbers -- - * - * Parses and compares two numbers (may be either entier() or double()). - * - * Results: - * TCL_OK if the numbers parse correctly, TCL_ERROR if one is not numeric - * at all, and TCL_BREAK if one or the other is "NaN". The resultPtr - * argument is used to update a variable with how the numbers relate to - * each other in the TCL_OK case. - * - * Side effects: - * None. - * - * Notes: - * This code originally extracted from tclExecute.c. - * - *---------------------------------------------------------------------- - */ - -static int -CompareNumbers( - Tcl_Interp *interp, /* Where to write error messages if any. */ - Tcl_Obj *numObj1, /* First number to compare. */ - Tcl_Obj *numObj2, /* Second number to compare. */ - int *resultPtr) /* Pointer to a variable to write the outcome - * of the comparison into. Must not be - * NULL. */ -{ - ClientData ptr1, ptr2; - int type1, type2; - double d1, d2, tmp; - long l1, l2; - mp_int big1, big2; -#ifndef NO_WIDE_TYPE - Tcl_WideInt w1, w2; -#endif - - if (TclGetNumberFromObj(interp, numObj1, &ptr1, &type1) != TCL_OK) { - return TCL_ERROR; - } - if (TclGetNumberFromObj(interp, numObj2, &ptr2, &type2) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Selected special cases. NaNs are not equal to *everything*, otherwise - * objects are equal to themselves. - */ - - if (type1 == TCL_NUMBER_NAN) { - /* NaN first arg: NaN != to everything, other compares are false */ - return TCL_BREAK; - } - if (numObj1 == numObj2) { - *resultPtr = MP_EQ; - return TCL_OK; - } - if (type2 == TCL_NUMBER_NAN) { - /* NaN 2nd arg: NaN != to everything, other compares are false */ - return TCL_BREAK; - } - - /* - * Big switch to pick apart the type rules and choose how to compare the - * two numbers. Also handles a few special cases along the way. - */ - - switch (type1) { - case TCL_NUMBER_LONG: - l1 = *((CONST long *)ptr1); - switch (type2) { - case TCL_NUMBER_LONG: - l2 = *((CONST long *)ptr2); - goto longCompare; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((CONST Tcl_WideInt *)ptr2); - w1 = (Tcl_WideInt)l1; - goto wideCompare; -#endif - case TCL_NUMBER_DOUBLE: - d2 = *((CONST double *)ptr2); - d1 = (double) l1; - - /* - * If the double has a fractional part, or if the long can be - * converted to double without loss of precision, then compare as - * doubles. - */ - - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) - || (l1 == (long) d1) || (modf(d2, &tmp) != 0.0)) { - goto doubleCompare; - } - - /* - * Otherwise, to make comparision based on full precision, need to - * convert the double to a suitably sized integer. - * - * Need this to get comparsions like - * expr 20000000000000003 < 20000000000000004.0 - * right. Converting the first argument to double will yield two - * double values that are equivalent within double precision. - * Converting the double to an integer gets done exactly, then - * integer comparison can tell the difference. - */ - - if (d2 < (double)LONG_MIN) { - *resultPtr = MP_GT; - return TCL_OK; - } - if (d2 > (double)LONG_MAX) { - *resultPtr = MP_LT; - return TCL_OK; - } - l2 = (long) d2; - goto longCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, numObj2, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - *resultPtr = MP_GT; - } else { - *resultPtr = MP_LT; - } - mp_clear(&big2); - } - return TCL_OK; - -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w1 = *((CONST Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_WIDE: - w2 = *((CONST Tcl_WideInt *)ptr2); - goto wideCompare; - case TCL_NUMBER_LONG: - l2 = *((CONST long *)ptr2); - w2 = (Tcl_WideInt)l2; - goto wideCompare; - case TCL_NUMBER_DOUBLE: - d2 = *((CONST double *)ptr2); - d1 = (double) w1; - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)) - || (w1 == (Tcl_WideInt) d1) || (modf(d2, &tmp) != 0.0)) { - goto doubleCompare; - } - if (d2 < (double)LLONG_MIN) { - *resultPtr = MP_GT; - return TCL_OK; - } - if (d2 > (double)LLONG_MAX) { - *resultPtr = MP_LT; - return TCL_OK; - } - w2 = (Tcl_WideInt) d2; - goto wideCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, numObj2, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - *resultPtr = MP_GT; - } else { - *resultPtr = MP_LT; - } - mp_clear(&big2); - } - return TCL_OK; -#endif - - case TCL_NUMBER_DOUBLE: - d1 = *((CONST double *)ptr1); - switch (type2) { - case TCL_NUMBER_DOUBLE: - d2 = *((CONST double *)ptr2); - goto doubleCompare; - case TCL_NUMBER_LONG: - l2 = *((CONST long *)ptr2); - d2 = (double) l2; - - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) - || (l2 == (long) d2) || (modf(d1, &tmp) != 0.0)) { - goto doubleCompare; - } - if (d1 < (double)LONG_MIN) { - *resultPtr = MP_LT; - return TCL_OK; - } - if (d1 > (double)LONG_MAX) { - *resultPtr = MP_GT; - return TCL_OK; - } - l1 = (long) d1; - goto longCompare; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((CONST Tcl_WideInt *)ptr2); - d2 = (double) w2; - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)) - || (w2 == (Tcl_WideInt) d2) || (modf(d1, &tmp) != 0.0)) { - goto doubleCompare; - } - if (d1 < (double)LLONG_MIN) { - *resultPtr = MP_LT; - return TCL_OK; - } - if (d1 > (double)LLONG_MAX) { - *resultPtr = MP_GT; - return TCL_OK; - } - w1 = (Tcl_WideInt) d1; - goto wideCompare; -#endif - case TCL_NUMBER_BIG: - if (TclIsInfinite(d1)) { - *resultPtr = (d1 > 0.0) ? MP_GT : MP_LT; - return TCL_OK; - } - Tcl_TakeBignumFromObj(NULL, numObj2, &big2); - if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { - if (mp_cmp_d(&big2, 0) == MP_LT) { - *resultPtr = MP_GT; - } else { - *resultPtr = MP_LT; - } - mp_clear(&big2); - return TCL_OK; - } - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) - && (modf(d1, &tmp) != 0.0)) { - d2 = TclBignumToDouble(&big2); - mp_clear(&big2); - goto doubleCompare; - } - Tcl_InitBignumFromDouble(NULL, d1, &big1); - goto bigCompare; - } - return TCL_OK; - - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, numObj1, &big1); - switch (type2) { -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: -#endif - case TCL_NUMBER_LONG: - *resultPtr = mp_cmp_d(&big1, 0); - mp_clear(&big1); - return TCL_OK; - case TCL_NUMBER_DOUBLE: - d2 = *((CONST double *)ptr2); - if (TclIsInfinite(d2)) { - *resultPtr = (d2 > 0.0) ? MP_LT : MP_GT; - mp_clear(&big1); - return TCL_OK; - } - if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { - *resultPtr = mp_cmp_d(&big1, 0); - mp_clear(&big1); - return TCL_OK; - } - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) - && (modf(d2, &tmp) != 0.0)) { - d1 = TclBignumToDouble(&big1); - mp_clear(&big1); - goto doubleCompare; - } - Tcl_InitBignumFromDouble(NULL, d2, &big2); - goto bigCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, numObj2, &big2); - goto bigCompare; - } - } - - /* - * Should really be impossible to get here - */ - - return TCL_OK; - - /* - * The real core comparison rules. - */ - - longCompare: - *resultPtr = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); - return TCL_OK; -#ifndef NO_WIDE_TYPE - wideCompare: - *resultPtr = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - return TCL_OK; -#endif - doubleCompare: - *resultPtr = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - return TCL_OK; - bigCompare: - *resultPtr = mp_cmp(&big1, &big2); - mp_clear(&big1); - mp_clear(&big2); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclInvertOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::~" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclInvertOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - ClientData val; - int type; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "number"); - return TCL_ERROR; - } - if (TclGetNumberFromObj(NULL, objv[1], &val, &type) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"~\"", -1)); - return TCL_ERROR; - } - switch (type) { - case TCL_NUMBER_NAN: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"~\"", - "non-numeric floating-point value")); - return TCL_ERROR; - case TCL_NUMBER_DOUBLE: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"~\"", "floating-point value")); - return TCL_ERROR; - case TCL_NUMBER_LONG: { - long l = *((const long *) val); - - Tcl_SetLongObj(Tcl_GetObjResult(interp), ~l); - return TCL_OK; - } -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: { - Tcl_WideInt w = *((const Tcl_WideInt *) val); - - Tcl_SetWideIntObj(Tcl_GetObjResult(interp), ~w); - return TCL_OK; - } -#endif - default: { - mp_int big; - - Tcl_TakeBignumFromObj(NULL, objv[1], &big); - /* ~a = - a - 1 */ - mp_neg(&big, &big); - mp_sub_d(&big, 1, &big); - if (Tcl_IsShared(objv[1])) { - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); - } else { - Tcl_SetBignumObj(objv[1], &big); - Tcl_SetObjResult(interp, objv[1]); - } - return TCL_OK; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclNotOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::!" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclNotOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int b; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "boolean"); - return TCL_ERROR; - } - if (Tcl_GetBooleanFromObj(NULL, objv[1], &b) != TCL_OK) { - int type; - ClientData val; - if (TclGetNumberFromObj(NULL, objv[1], &val, &type) == TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric floating-point value as operand of \"!\"", -1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"!\"", -1)); - } - return TCL_ERROR; - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), !b); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclAddOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::+" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclAddOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 2) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - return TCL_OK; - } else if (objc == 2) { - ClientData ptr1; - int type1; - if (TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"+\"",-1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } else if (objc == 3) { - /* - * This is a special case of the version with the loop that allows for - * better memory management of objects in some cases. - */ - - Tcl_Obj *resPtr = CombineIntFloat(interp, objv[1], INST_ADD, objv[2]); - if (resPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - } else { - Tcl_Obj *sumPtr = objv[1]; - int i; - - Tcl_IncrRefCount(sumPtr); - for (i=2 ; i=1 ; i--) { - Tcl_Obj *resPtr = CombineIntFloat(interp, objv[i], INST_EXPON, - powPtr); - - if (resPtr == NULL) { - TclDecrRefCount(powPtr); - return TCL_ERROR; - } - Tcl_IncrRefCount(resPtr); - TclDecrRefCount(powPtr); - powPtr = resPtr; - } - Tcl_SetObjResult(interp, powPtr); - Tcl_DecrRefCount(powPtr); /* Public form since we know we won't - * be freeing this object now. */ - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclMinusOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::-" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclMinusOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "value ?value ...?"); - return TCL_ERROR; - } else if (objc == 2) { - /* - * Only a single argument, so we compute the negation. - */ - - Tcl_Obj *zeroPtr = Tcl_NewIntObj(0); - Tcl_Obj *resPtr; - - Tcl_IncrRefCount(zeroPtr); - resPtr = CombineIntFloat(interp, zeroPtr, INST_SUB, objv[1]); - if (resPtr == NULL) { - TclDecrRefCount(zeroPtr); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - TclDecrRefCount(zeroPtr); - return TCL_OK; - } else if (objc == 3) { - /* - * This is a special case of the version with the loop that allows for - * better memory management of objects in some cases. - */ - - Tcl_Obj *resPtr = CombineIntFloat(interp, objv[1], INST_SUB, objv[2]); - if (resPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - } else { - Tcl_Obj *diffPtr = objv[1]; - int i; - - Tcl_IncrRefCount(diffPtr); - for (i=2 ; i (long) INT_MAX)) { - /* - * Technically, we could hold the value (1 << (INT_MAX+1)) in an - * mp_int, but since we're using mp_mul_2d() to do the work, and it - * takes only an int argument, that's a good place to draw the line. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - return TCL_ERROR; - } - shift = (int)(*((const long *)ptr2)); - - /* Handle shifts within the native long range */ - if ((type1 == TCL_NUMBER_LONG) && ((size_t)shift < CHAR_BIT*sizeof(long)) - && (l1 = *((CONST long *)ptr1)) && - !(((l1>0) ? l1 : ~l1) & -(1L<<(CHAR_BIT*sizeof(long)-1-shift)))) { - Tcl_SetObjResult(interp, Tcl_NewLongObj(l1<0) ? w : ~w) & -(((Tcl_WideInt)1) - << (CHAR_BIT*sizeof(Tcl_WideInt)-1-shift)))) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(w<>" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclRshiftOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - ClientData ptr1, ptr2; - int invalid, shift, type1, type2, idx; - const char *description; - long l1; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value value"); - return TCL_ERROR; - } - - if ((TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) - || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { - idx = 1; - goto illegalOperand; - } - if ((TclGetNumberFromObj(NULL, objv[2], &ptr2, &type2) != TCL_OK) - || (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { - idx = 2; - goto illegalOperand; - } - - /* reject negative shift argument */ - switch (type2) { - case TCL_NUMBER_LONG: - invalid = (*((const long *)ptr2) < (long)0); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); - break; -#endif - case TCL_NUMBER_BIG: - /* TODO: const correctness ? */ - invalid = (mp_cmp_d((mp_int *)ptr2, 0) == MP_LT); - break; - default: - /* Unused, here to silence compiler warning */ - invalid = 0; - } - if (invalid) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("negative shift argument", -1)); - return TCL_ERROR; - } - - /* Zero shifted any number of bits is still zero */ - if ((type1 == TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - return TCL_OK; - } - - /* Quickly force large right shifts to 0 or -1 */ - if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > INT_MAX)) { - /* - * Again, technically, the value to be shifted could be an mp_int so - * huge that a right shift by (INT_MAX+1) bits could not take us to - * the result of 0 or -1, but since we're using mp_div_2d to do the - * work, and it takes only an int argument, we draw the line there. - */ - - int zero; - - switch (type1) { - case TCL_NUMBER_LONG: - zero = (*((const long *)ptr1) > (long)0); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - zero = (*((const Tcl_WideInt *)ptr1) > (Tcl_WideInt)0); - break; -#endif - case TCL_NUMBER_BIG: - /* TODO: const correctness ? */ - zero = (mp_cmp_d((mp_int *)ptr1, 0) == MP_GT); - break; - default: - /* Unused, here to silence compiler warning. */ - zero = 0; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(zero ? 0 : -1)); - return TCL_OK; - } - - shift = (int)(*((const long *)ptr2)); - /* Handle shifts within the native long range */ - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *)ptr1); - if ((size_t)shift >= CHAR_BIT*sizeof(long)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(l1 >= (long)0 ? 0 : -1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(l1 >> shift)); - } - return TCL_OK; - } - -#ifndef NO_WIDE_TYPE - /* Handle shifts within the native wide range */ - if (type1 == TCL_NUMBER_WIDE) { - Tcl_WideInt w = *((const Tcl_WideInt *)ptr1); - if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { - Tcl_SetObjResult(interp, - Tcl_NewIntObj(w >= (Tcl_WideInt)0 ? 0 : -1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(w >> shift)); - } - return TCL_OK; - } -#endif - - { - mp_int big, bigResult, bigRemainder; - - Tcl_TakeBignumFromObj(NULL, objv[1], &big); - - mp_init(&bigResult); - mp_init(&bigRemainder); - mp_div_2d(&big, shift, &bigResult, &bigRemainder); - if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { - /* Convert to Tcl's integer division rules */ - mp_sub_d(&bigResult, 1, &bigResult); - } - mp_clear(&bigRemainder); - mp_clear(&big); - - if (!Tcl_IsShared(objv[1])) { - Tcl_SetBignumObj(objv[1], &bigResult); - Tcl_SetObjResult(interp, objv[1]); - } else { - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&bigResult)); - } - } - return TCL_OK; - - illegalOperand: - if (TclGetNumberFromObj(NULL, objv[idx], &ptr1, &type1) != TCL_OK) { - int numBytes; - const char *bytes = Tcl_GetStringFromObj(objv[idx], &numBytes); - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } - } else if (type1 == TCL_NUMBER_NAN) { - description = "non-numeric floating-point value"; - } else { - description = "floating-point value"; - } - - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("can't use %s as operand of \">>\"", description)); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclModOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::%" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclModOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *argObj; - ClientData ptr1, ptr2; - int type1, type2; - long l1, l2 = 0; - const char *description; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value value"); - return TCL_ERROR; - } - - if ((TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) - || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { - argObj = objv[1]; - goto badArg; - } - if ((TclGetNumberFromObj(NULL, objv[2], &ptr2, &type2) != TCL_OK) - || (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { - argObj = objv[2]; - goto badArg; - } - - if (type2 == TCL_NUMBER_LONG) { - l2 = *((CONST long *)ptr2); - if (l2 == 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", - NULL); - return TCL_ERROR; - } - if ((l2 == 1) || (l2 == -1)) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - return TCL_OK; - } - } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((CONST long *)ptr1); - if (l1 == 0) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - return TCL_OK; - } - if (type2 == TCL_NUMBER_LONG) { - /* Both operands are long; do native calculation */ - long lRemainder, lQuotient = l1 / l2; - - /* Force Tcl's integer division rules */ - /* TODO: examine for logic simplification */ - if (((lQuotient < 0) || ((lQuotient == 0) && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - ((lQuotient * l2) != l1)) { - lQuotient -= 1; - } - lRemainder = l1 - l2*lQuotient; - Tcl_SetLongObj(Tcl_GetObjResult(interp), lRemainder); - return TCL_OK; - } - /* - * First operand fits in long; second does not, so the second has - * greater magnitude than first. No need to divide to determine the - * remainder. - */ -#ifndef NO_WIDE_TYPE - if (type2 == TCL_NUMBER_WIDE) { - Tcl_WideInt w2 = *((CONST Tcl_WideInt *)ptr2); - - if ((l1 > 0) ^ (w2 > (Tcl_WideInt)0)) { - /* Arguments are opposite sign; remainder is sum */ - Tcl_SetObjResult(interp, - Tcl_NewWideIntObj(w2+(Tcl_WideInt)l1)); - return TCL_OK; - } - /* Arguments are same sign; remainder is first operand */ - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } -#endif - { - mp_int big2; - Tcl_TakeBignumFromObj(NULL, objv[2], &big2); - - /* TODO: internals intrusion */ - if ((l1 > 0) ^ (big2.sign == MP_ZPOS)) { - /* Arguments are opposite sign; remainder is sum */ - mp_int big1; - TclBNInitBignumFromLong(&big1, l1); - mp_add(&big2, &big1, &big2); - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big2)); - } else { - /* Arguments are same sign; remainder is first operand */ - Tcl_SetObjResult(interp, objv[1]); - /* TODO: free big2? */ - } - } - return TCL_OK; - } -#ifndef NO_WIDE_TYPE - if (type1 == TCL_NUMBER_WIDE) { - Tcl_WideInt w1 = *((CONST Tcl_WideInt *)ptr1); - if (type2 != TCL_NUMBER_BIG) { - Tcl_WideInt w2, wQuotient, wRemainder; - - Tcl_GetWideIntFromObj(NULL, objv[2], &w2); - wQuotient = w1 / w2; - - /* Force Tcl's integer division rules */ - /* TODO: examine for logic simplification */ - if (((wQuotient < ((Tcl_WideInt) 0)) - || ((wQuotient == ((Tcl_WideInt) 0)) && ( - (w1 < ((Tcl_WideInt) 0) && w2 > ((Tcl_WideInt) 0)) - || (w1 > ((Tcl_WideInt) 0) && w2 < ((Tcl_WideInt) 0))) - )) && ((wQuotient * w2) != w1)) { - wQuotient -= (Tcl_WideInt) 1; - } - wRemainder = w1 - w2*wQuotient; - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wRemainder)); - } else { - mp_int big2; - Tcl_TakeBignumFromObj(NULL, objv[2], &big2); - - /* TODO: internals intrusion */ - if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) { - /* Arguments are opposite sign; remainder is sum */ - mp_int big1; - TclBNInitBignumFromWideInt(&big1, w1); - mp_add(&big2, &big1, &big2); - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big2)); - } else { - /* Arguments are same sign; remainder is first operand */ - Tcl_SetObjResult(interp, objv[1]); - } - } - return TCL_OK; - } -#endif - { - mp_int big1, big2, bigResult, bigRemainder; - - Tcl_GetBignumFromObj(NULL, objv[1], &big1); - Tcl_GetBignumFromObj(NULL, objv[2], &big2); - mp_init(&bigResult); - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); - if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { - /* Convert to Tcl's integer division rules */ - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); - } - mp_copy(&bigRemainder, &bigResult); - mp_clear(&bigRemainder); - mp_clear(&big1); - mp_clear(&big2); - if (Tcl_IsShared(objv[1])) { - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&bigResult)); - } else { - Tcl_SetBignumObj(objv[1], &bigResult); - Tcl_SetObjResult(interp, objv[1]); - } - return TCL_OK; - } - - badArg: - if (TclGetNumberFromObj(NULL, argObj, &ptr1, &type1) != TCL_OK) { - int numBytes; - CONST char *bytes = Tcl_GetStringFromObj(argObj, &numBytes); - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } - } else if (type1 == TCL_NUMBER_NAN) { - description = "non-numeric floating-point value"; - } else { - description = "floating-point value"; - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"%%\"", description)); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclNeqOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::!=" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclNeqOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1, cmp, len1, len2; - const char *str1, *str2; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value value"); - return TCL_ERROR; - } - - switch (CompareNumbers(NULL, objv[1], objv[2], &cmp)) { - case TCL_ERROR: - /* - * Got a string - */ - str1 = Tcl_GetStringFromObj(objv[1], &len1); - str2 = Tcl_GetStringFromObj(objv[2], &len2); - if (len1 == len2 && !strcmp(str1, str2)) { - result = 0; - } - case TCL_BREAK: /* Deliberate fallthrough */ - break; - case TCL_OK: - /* - * Got proper numbers - */ - if (cmp == MP_EQ) { - result = 0; - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclStrneqOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::ne" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclStrneqOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - const char *s1, *s2; - int s1len, s2len; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value value"); - return TCL_ERROR; - } - - s1 = Tcl_GetStringFromObj(objv[1], &s1len); - s2 = Tcl_GetStringFromObj(objv[2], &s2len); - if (s1len == s2len && !strcmp(s1, s2)) { - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); - } else { - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclInOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::in" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclInOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - const char *s1, *s2; - int s1len, s2len, i, len; - Tcl_Obj **listObj; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value list"); - return TCL_ERROR; - } - - if (Tcl_ListObjGetElements(interp, objv[2], &len, &listObj) != TCL_OK) { - return TCL_ERROR; - } - s1 = Tcl_GetStringFromObj(objv[1], &s1len); - for (i=0 ; i 2) { - int i, cmp, len1, len2; - const char *str1, *str2; - - for (i=1 ; i= 0) { - result = 0; - i = objc; - } - continue; - case TCL_OK: - /* - * Got proper numbers - */ - if (cmp != MP_LT) { - result = 0; - i = objc; - } - continue; - case TCL_BREAK: - /* - * Got a NaN (which is different from everything, including - * itself) - */ - result = 0; - i = objc; - continue; - } - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclLeqOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::<=" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclLeqOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1; - - if (objc > 2) { - int i, cmp, len1, len2; - const char *str1, *str2; - - for (i=1 ; i 0) { - result = 0; - i = objc; - } - continue; - case TCL_OK: - /* - * Got proper numbers - */ - if (cmp == MP_GT) { - result = 0; - i = objc; - } - continue; - case TCL_BREAK: - /* - * Got a NaN (which is different from everything, including - * itself) - */ - result = 0; - i = objc; - continue; - } - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclGreaterOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::>" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclGreaterOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1; - - if (objc > 2) { - int i, cmp, len1, len2; - const char *str1, *str2; - - for (i=1 ; i=" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclGeqOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1; - - if (objc > 2) { - int i, cmp, len1, len2; - const char *str1, *str2; - - for (i=1 ; i 2) { - int i, cmp, len1, len2; - const char *str1, *str2; - - for (i=1 ; i 2) { - int i, len1, len2; - const char *str1, *str2; - - for (i=1 ; inum ; ++i) { + if (recPtr->list[i] == NULL) { + recPtr->list[i] = objPtr; + return; + } + } + + /* + * Grow the list of pointers if necessary, copying only non-NULL + * pointers to the new list. */ if (recPtr->num >= recPtr->max) { @@ -179,6 +190,7 @@ RememberSyncObject( recPtr->list = newList; recPtr->num = j; } + recPtr->list[recPtr->num] = objPtr; recPtr->num++; } diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index c0bb338..387e96d 100755 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -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. * - * RCS: @(#) $Id: tclThreadAlloc.c,v 1.21 2006/08/10 12:15:31 dkf Exp $ + * RCS: @(#) $Id: tclThreadAlloc.c,v 1.21.6.1 2007/07/01 17:31:25 dgp Exp $ */ #include "tclInt.h" #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - + /* * If range checking is enabled, an additional byte will be allocated to store * the magic number at the end of the requested memory. @@ -40,12 +40,14 @@ #define NOBJHIGH 1200 /* - * The following defines the number of buckets in the bucket cache and those - * block sizes from (1<<4) to (1<<(3+NBUCKETS)) + * Alignment for allocated memory. */ -#define NBUCKETS 11 -#define MAXALLOC 16284 +#if defined(__APPLE__) +#define ALLOCALIGN 16 +#else +#define ALLOCALIGN 8 +#endif /* * The following union stores accounting information for each block including @@ -54,23 +56,36 @@ * is also maintained. */ -typedef struct Block { - union { - struct Block *next; /* Next in free list. */ - struct { - unsigned char magic1; /* First magic number. */ - unsigned char bucket; /* Bucket block allocated from. */ - unsigned char unused; /* Padding. */ - unsigned char magic2; /* Second magic number. */ - } s; - } u; - size_t reqSize; /* Requested allocation size. */ +typedef union Block { + struct { + union { + union Block *next; /* Next in free list. */ + struct { + unsigned char magic1; /* First magic number. */ + unsigned char bucket; /* Bucket block allocated from. */ + unsigned char unused; /* Padding. */ + unsigned char magic2; /* Second magic number. */ + } s; + } u; + size_t reqSize; /* Requested allocation size. */ + } b; + unsigned char padding[ALLOCALIGN]; } Block; -#define nextBlock u.next -#define sourceBucket u.s.bucket -#define magicNum1 u.s.magic1 -#define magicNum2 u.s.magic2 +#define nextBlock b.u.next +#define sourceBucket b.u.s.bucket +#define magicNum1 b.u.s.magic1 +#define magicNum2 b.u.s.magic2 #define MAGIC 0xEF +#define blockReqSize b.reqSize + +/* + * The following defines the minimum and and maximum block sizes and the number + * of buckets in the bucket cache. + */ + +#define MINALLOC ((sizeof(Block) + 8 + (ALLOCALIGN-1)) & ~(ALLOCALIGN-1)) +#define NBUCKETS (11 - (MINALLOC >> 5)) +#define MAXALLOC (MINALLOC << (NBUCKETS - 1)) /* * The following structure defines a bucket of blocks with various accounting @@ -114,19 +129,7 @@ static struct { int maxBlocks; /* Max blocks before move to share. */ int numMove; /* Num blocks to move to share. */ Tcl_Mutex *lockPtr; /* Share bucket lock. */ -} bucketInfo[NBUCKETS] = { - { 16, 1024, 512, NULL}, - { 32, 512, 256, NULL}, - { 64, 256, 128, NULL}, - { 128, 128, 64, NULL}, - { 256, 64, 32, NULL}, - { 512, 32, 16, NULL}, - { 1024, 16, 8, NULL}, - { 2048, 8, 4, NULL}, - { 4096, 4, 2, NULL}, - { 8192, 2, 1, NULL}, - {16284, 1, 1, NULL}, -}; +} bucketInfo[NBUCKETS]; /* * Static functions defined in this file. @@ -178,7 +181,7 @@ GetCache(void) if (listLockPtr == NULL) { Tcl_Mutex *initLockPtr; - int i; + unsigned int i; initLockPtr = Tcl_GetAllocMutex(); Tcl_MutexLock(initLockPtr); @@ -186,6 +189,10 @@ GetCache(void) listLockPtr = TclpNewAllocMutex(); objLockPtr = TclpNewAllocMutex(); for (i = 0; i < NBUCKETS; ++i) { + bucketInfo[i].blockSize = MINALLOC << i; + bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); + bucketInfo[i].numMove = i < NBUCKETS - 1 ? + 1 << (NBUCKETS - 2 - i) : 1; bucketInfo[i].lockPtr = TclpNewAllocMutex(); } } @@ -234,7 +241,7 @@ TclFreeAllocCache( { Cache *cachePtr = arg; Cache **nextPtrPtr; - register int bucket; + register unsigned int bucket; /* * Flush blocks. @@ -379,12 +386,12 @@ TclpFree( blockPtr = Ptr2Block(ptr); bucket = blockPtr->sourceBucket; if (bucket == NBUCKETS) { - cachePtr->totalAssigned -= blockPtr->reqSize; + cachePtr->totalAssigned -= blockPtr->blockReqSize; free(blockPtr); return; } - cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize; + cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; cachePtr->buckets[bucket].firstPtr = blockPtr; ++cachePtr->buckets[bucket].numFree; @@ -450,12 +457,12 @@ TclpRealloc( min = 0; } if (size > min && size <= bucketInfo[bucket].blockSize) { - cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize; + cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; cachePtr->buckets[bucket].totalAssigned += reqSize; return Block2Ptr(blockPtr, bucket, reqSize); } } else if (size > MAXALLOC) { - cachePtr->totalAssigned -= blockPtr->reqSize; + cachePtr->totalAssigned -= blockPtr->blockReqSize; cachePtr->totalAssigned += reqSize; blockPtr = realloc(blockPtr, size); if (blockPtr == NULL) { @@ -470,8 +477,8 @@ TclpRealloc( new = TclpAlloc(reqSize); if (new != NULL) { - if (reqSize > blockPtr->reqSize) { - reqSize = blockPtr->reqSize; + if (reqSize > blockPtr->blockReqSize) { + reqSize = blockPtr->blockReqSize; } memcpy(new, ptr, reqSize); TclpFree(ptr); @@ -617,7 +624,7 @@ Tcl_GetMemoryInfo( { Cache *cachePtr; char buf[200]; - int n; + unsigned int n; Tcl_MutexLock(listLockPtr); cachePtr = firstCachePtr; @@ -719,7 +726,7 @@ Block2Ptr( blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC; blockPtr->sourceBucket = bucket; - blockPtr->reqSize = reqSize; + blockPtr->blockReqSize = reqSize; ptr = ((void *) (blockPtr + 1)); #if RCHECK ((unsigned char *)(ptr))[reqSize] = MAGIC; @@ -739,10 +746,10 @@ Ptr2Block( blockPtr, blockPtr->magicNum1, blockPtr->magicNum2); } #if RCHECK - if (((unsigned char *) ptr)[blockPtr->reqSize] != MAGIC) { + if (((unsigned char *) ptr)[blockPtr->blockReqSize] != MAGIC) { Tcl_Panic("alloc: invalid block: %p: %x %x %x", blockPtr, blockPtr->magicNum1, blockPtr->magicNum2, - ((unsigned char *) ptr)[blockPtr->reqSize]); + ((unsigned char *) ptr)[blockPtr->blockReqSize]); } #endif return blockPtr; @@ -973,7 +980,8 @@ GetBlocks( void TclFinalizeThreadAlloc(void) { - int i; + unsigned int i; + for (i = 0; i < NBUCKETS; ++i) { TclpFreeAllocMutex(bucketInfo[i].lockPtr); bucketInfo[i].lockPtr = NULL; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 11221a5..9aad7ea 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.37.2.3 2007/06/27 22:44:48 dgp Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.37.2.4 2007/07/01 17:31:25 dgp Exp $ */ #include "tclInt.h" @@ -2281,7 +2281,7 @@ StringTraceProc( (data->proc)(data->clientData, interp, level, (char *) command, cmdPtr->proc, cmdPtr->clientData, objc, argv); - TclStackFree(interp, argv); + TclStackFree(interp, (void *)argv); return TCL_OK; } diff --git a/macosx/README b/macosx/README index 49c17ce..1f36d07 100644 --- a/macosx/README +++ b/macosx/README @@ -1,7 +1,7 @@ Tcl Mac OS X README ------------------- -RCS: @(#) $Id: README,v 1.12 2007/04/23 20:46:13 das Exp $ +RCS: @(#) $Id: README,v 1.12.2.1 2007/07/01 17:31:25 dgp Exp $ This is the README file for the Mac OS X/Darwin version of Tcl. @@ -95,11 +95,16 @@ take care to only use the project matching your DevTools and OS version: has ZeroLink and Fix&Continue enabled, use the 'DevelNoFixZL' buildstyle if you need a debug build without these features. * Tcl.xcodeproj for Xcode 2.4 on 10.4 or later, which has the following - additional configurations for the 'Tcl' and 'tcltest' targets: + additional build configurations for the 'Tcl' and 'tcltest' targets: + 'DebugUnthreaded': debug build with threading turned off. + 'DebugMemCompile': debug build with memory and bytecode debugging on. + 'DebugLeaks': debug build with PURIFY defined. 'Debug64bit': builds the targets as 64bit with debugging enabled, requires a 64bit capable processor (i.e. G5 or Core2/Xeon). 'ReleaseUniversal': builds the targets as universal binaries for the ppc, ppc64, i386 and x86_64 architectures. + 'ReleaseUniversal10.5SDK': same as 'ReleaseUniversal' but builds + against the 10.5 SDK on Leopard (with 10.5 deployment target). 'ReleaseUniversal10.4uSDK': same as 'ReleaseUniversal' but builds against the 10.4u SDK, required to build universal binaries on PowerPC Tiger (where the system libraries are not universal). @@ -109,19 +114,21 @@ take care to only use the project matching your DevTools and OS version: 10.2.8 SDK, useful to verify on Tiger that building on Jaguar would succeed. Notes about the native targets of the Xcode projects: - * the Xcode projects refer to the tcl source directory with a relative path - of ../../tcl to the project location, if your source directory is named - differently you'll need to enter the correct path in the info panel of - the 'Tcl Sources' group. - * XCode 1.5 has a bug that causes Fix&Continue and the Build menu items + * the Xcode 2 project refers to the toplevel tcl source directory through + the TCL_SRCROOT user build setting, by default this is set to the + project-relative path '../../tcl', if your tcl source directory is named + differently, e.g. '../../tcl8.5', you'll need to manually change the + TCL_SRCROOT setting by editing your ${USER}.pbxuser file (located inside + the Tcl.xcodeproj bundle directory) with a text editor. + * Xcode 1.5 has a bug that causes Fix&Continue and the Build menu items Compile/Preprocess/ShowAssembly to fail in presence of relative paths to source files, as a workaround change the Path Type of the 'Tcl Sources' group to 'Absolute Path' in the group's Info panel. (fixed in Xcode 2.2) * the native targets need a version of the unix configure script with config headers enabled, this is automatically generated as tcl/macosx/configure - by the project but this requires 2.59 versions of autoconf & autoheader, - which are not available on on Mac OS X 10.3 by default, and so need to - be installed manually. By default they are assumed to be installed as + by the project but that requires 2.59 versions of autoconf & autoheader. + These are not available on on Mac OS X 10.3 by default and need to be + installed manually. By default they are assumed to be installed as /usr/local/bin/autoconf-2.59 and /usr/local/bin/autoheader-2.59, set the env vars AUTOCONF and AUTOHEADER to their true locations if necessary. diff --git a/macosx/Tcl-Common.xcconfig b/macosx/Tcl-Common.xcconfig index 1cc7b2d..20b85af 100644 --- a/macosx/Tcl-Common.xcconfig +++ b/macosx/Tcl-Common.xcconfig @@ -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: Tcl-Common.xcconfig,v 1.3.2.1 2007/06/12 15:56:44 dgp Exp $ +// RCS: @(#) $Id: Tcl-Common.xcconfig,v 1.3.2.2 2007/07/01 17:31:25 dgp Exp $ // HEADER_SEARCH_PATHS = $(DERIVED_FILE_DIR)/tcl $(HEADER_SEARCH_PATHS) @@ -37,6 +37,5 @@ PREFIX = /usr/local TCL_CONFIGURE_ARGS = --enable-threads TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION) TCL_PACKAGE_PATH = "$(LIBDIR)" -TCL_SRCROOT = $(SRCROOT)/../../tcl TCL_DEFS = HAVE_TCL_CONFIG_H VERSION = 8.5 diff --git a/macosx/Tcl.xcodeproj/default.pbxuser b/macosx/Tcl.xcodeproj/default.pbxuser index 5e886f3..09d2b55 100644 --- a/macosx/Tcl.xcodeproj/default.pbxuser +++ b/macosx/Tcl.xcodeproj/default.pbxuser @@ -18,6 +18,7 @@ userBuildSettings = { GCC = /usr/bin/gcc; SYMROOT = "${SRCROOT}/../../build/tcl"; + TCL_SRCROOT = "${SRCROOT}/../../tcl"; }; }; 8DD76FA90486AB0100D96B5E /* tcltest */ = { @@ -35,7 +36,7 @@ NO, ); argumentStrings = ( - "${SRCROOT}/../../tcl/tests/all.tcl", + "${TCL_SRCROOT}/tests/all.tcl", "-singleproc 1", "-verbose \"bet\"", ); @@ -73,7 +74,7 @@ { active = YES; name = TCL_LIBRARY; - value = "${SRCROOT}/../../tcl/library"; + value = "${TCL_SRCROOT}/library"; }, { active = YES; diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index 27764e3..3dc0fd4 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -8,7 +8,6 @@ /* Begin PBXBuildFile section */ F90509300913A72400327603 /* tclAppInit.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D445508F272B9004A47F5 /* tclAppInit.c */; settings = {COMPILER_FLAGS = "-DTCL_TEST -DTCL_BUILDTIME_LIBRARY=\\\"$(TCL_SRCROOT)/library\\\""; }; }; - F9408AF30B195C08009F7CAC /* tclMathOp.c in Sources */ = {isa = PBXBuildFile; fileRef = F9408AF20B195C08009F7CAC /* tclMathOp.c */; }; F966C07508F2820D005CB29B /* CoreFoundation.framework in Frameworks */ = {isa = PBXBuildFile; fileRef = F966C07408F2820D005CB29B /* CoreFoundation.framework */; }; F96D456F08F272BB004A47F5 /* regcomp.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3ED008F272A7004A47F5 /* regcomp.c */; }; F96D457208F272BB004A47F5 /* regerror.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3ED308F272A7004A47F5 /* regerror.c */; }; @@ -177,7 +176,6 @@ /* Begin PBXFileReference section */ 8DD76FB20486AB0100D96B5E /* tcltest */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = tcltest; sourceTree = BUILT_PRODUCTS_DIR; }; F91E62260C1AE686006C9D96 /* Tclsh-Info.plist.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.xml; path = "Tclsh-Info.plist.in"; sourceTree = ""; }; - F9408AF20B195C08009F7CAC /* tclMathOp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclMathOp.c; sourceTree = ""; }; F95FAFF90B34F1130072E431 /* macOSXLoad.test */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = macOSXLoad.test; sourceTree = ""; }; F966C07408F2820D005CB29B /* CoreFoundation.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = CoreFoundation.framework; path = /System/Library/Frameworks/CoreFoundation.framework; sourceTree = ""; }; F96D3DFA08F272A4004A47F5 /* ChangeLog */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = ChangeLog; sourceTree = ""; }; @@ -933,7 +931,7 @@ F966C06F08F281DC005CB29B /* Frameworks */, 1AB674ADFE9D54B511CA2CBB /* Products */, ); - comments = "Copyright (c) 2004-2007 Daniel A. Steffen \n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\nRCS: @(#) $Id: project.pbxproj,v 1.21.2.1 2007/06/12 15:56:44 dgp Exp $\n"; + comments = "Copyright (c) 2004-2007 Daniel A. Steffen \n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\nRCS: @(#) $Id: project.pbxproj,v 1.21.2.2 2007/07/01 17:31:25 dgp Exp $\n"; name = Tcl; path = .; sourceTree = SOURCE_ROOT; @@ -975,8 +973,7 @@ F96D432B08F272B4004A47F5 /* license.terms */, ); name = "Tcl Sources"; - path = ../../tcl; - sourceTree = SOURCE_ROOT; + sourceTree = TCL_SRCROOT; }; F96D3DFC08F272A4004A47F5 /* doc */ = { isa = PBXGroup; @@ -1259,7 +1256,6 @@ F96D3F0808F272A7004A47F5 /* tclLoad.c */, F96D3F0908F272A7004A47F5 /* tclLoadNone.c */, F96D3F0A08F272A7004A47F5 /* tclMain.c */, - F9408AF20B195C08009F7CAC /* tclMathOp.c */, F96D3F0B08F272A7004A47F5 /* tclNamesp.c */, F96D3F0C08F272A7004A47F5 /* tclNotify.c */, F96D3F0D08F272A7004A47F5 /* tclObj.c */, @@ -2031,7 +2027,6 @@ F96D45A608F272BC004A47F5 /* tclLiteral.c in Sources */, F96D45A708F272BC004A47F5 /* tclLoad.c in Sources */, F96D45A908F272BC004A47F5 /* tclMain.c in Sources */, - F9408AF30B195C08009F7CAC /* tclMathOp.c in Sources */, F96D45AA08F272BC004A47F5 /* tclNamesp.c in Sources */, F96D45AB08F272BC004A47F5 /* tclNotify.c in Sources */, F96D45AC08F272BC004A47F5 /* tclObj.c in Sources */, @@ -2539,7 +2534,7 @@ ARCHS = ppc; CFLAGS = "$(PER_ARCH_CFLAGS_ppc) $(CFLAGS)"; CPPFLAGS = "-arch ppc -isysroot $(SDKROOT) $(CPPFLAGS)"; - MACOSX_DEPLOYMENT_TARGET = 10.2; + MACOSX_DEPLOYMENT_TARGET = 10.3; PREBINDING = YES; SDKROOT = /Developer/SDKs/MacOSX10.3.9.sdk; }; @@ -2579,6 +2574,48 @@ }; name = ReleasePPC10.2.8SDK; }; + F9EEED960C2FEFD300396116 /* ReleaseUniversal10.5SDK */ = { + isa = XCBuildConfiguration; + buildSettings = { + PRODUCT_NAME = tclsh; + }; + name = ReleaseUniversal10.5SDK; + }; + F9EEED970C2FEFD300396116 /* ReleaseUniversal10.5SDK */ = { + isa = XCBuildConfiguration; + buildSettings = { + PRODUCT_NAME = tcltest; + }; + name = ReleaseUniversal10.5SDK; + }; + F9EEED980C2FEFD300396116 /* ReleaseUniversal10.5SDK */ = { + isa = XCBuildConfiguration; + buildSettings = { + PRODUCT_NAME = tests; + TCLTEST_OPTIONS = ""; + TCL_LIBRARY = "$(TCL_SRCROOT)/library"; + TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest"; + }; + name = ReleaseUniversal10.5SDK; + }; + F9EEED990C2FEFD300396116 /* ReleaseUniversal10.5SDK */ = { + isa = XCBuildConfiguration; + baseConfigurationReference = F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */; + buildSettings = { + ARCHS = ( + ppc, + ppc64, + i386, + x86_64, + ); + CFLAGS = "-arch ppc -arch ppc64 -arch i386 -arch x86_64 $(CFLAGS)"; + CPPFLAGS = "-isysroot $(SDKROOT) $(CPPFLAGS)"; + MACOSX_DEPLOYMENT_TARGET = 10.5; + PREBINDING = NO; + SDKROOT = /Developer/SDKs/MacOSX10.5.sdk; + }; + name = ReleaseUniversal10.5SDK; + }; /* End XCBuildConfiguration section */ /* Begin XCConfigurationList section */ @@ -2593,6 +2630,7 @@ F97AED1B0B660B2100310EA2 /* Debug64bit */, F95CC8AD09158F3100EA5ACE /* Release */, F91BCC4F093152310042A6BF /* ReleaseUniversal */, + F9EEED960C2FEFD300396116 /* ReleaseUniversal10.5SDK */, F9DB62080B65ADA800A370FB /* ReleaseUniversal10.4uSDK */, F9DB621F0B65AFDE00A370FB /* ReleasePPC10.3.9SDK */, F9DB62350B65B03A00A370FB /* ReleasePPC10.2.8SDK */, @@ -2611,6 +2649,7 @@ F97AED1C0B660B2100310EA2 /* Debug64bit */, F95CC8B209158F3100EA5ACE /* Release */, F91BCC50093152310042A6BF /* ReleaseUniversal */, + F9EEED970C2FEFD300396116 /* ReleaseUniversal10.5SDK */, F9DB62090B65ADA800A370FB /* ReleaseUniversal10.4uSDK */, F9DB62200B65AFDE00A370FB /* ReleasePPC10.3.9SDK */, F9DB62360B65B03A00A370FB /* ReleasePPC10.2.8SDK */, @@ -2629,6 +2668,7 @@ F97AED1E0B660B2100310EA2 /* Debug64bit */, F95CC8B709158F3100EA5ACE /* Release */, F91BCC51093152310042A6BF /* ReleaseUniversal */, + F9EEED990C2FEFD300396116 /* ReleaseUniversal10.5SDK */, F9DB620A0B65ADA800A370FB /* ReleaseUniversal10.4uSDK */, F9DB62210B65AFDE00A370FB /* ReleasePPC10.3.9SDK */, F9DB62370B65B03A00A370FB /* ReleasePPC10.2.8SDK */, @@ -2647,6 +2687,7 @@ F97AED1D0B660B2100310EA2 /* Debug64bit */, F97258AA0A86873D00096C78 /* Release */, F97258AC0A86873D00096C78 /* ReleaseUniversal */, + F9EEED980C2FEFD300396116 /* ReleaseUniversal10.5SDK */, F97AED080B660A6C00310EA2 /* ReleaseUniversal10.4uSDK */, F97AED0F0B660AA300310EA2 /* ReleasePPC10.3.9SDK */, F97AED160B660AF100310EA2 /* ReleasePPC10.2.8SDK */, diff --git a/unix/Makefile.in b/unix/Makefile.in index 838c433..f5e14e3 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.207.2.2 2007/06/12 15:56:44 dgp Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.207.2.3 2007/07/01 17:31:25 dgp Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -300,7 +300,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ - tclLiteral.o tclLoad.o tclMain.o tclMathOp.o tclNamesp.o tclNotify.o \ + tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ tclPreserve.o tclProc.o tclRegexp.o \ @@ -397,7 +397,6 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclLiteral.c \ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ - $(GENERIC_DIR)/tclMathOp.c \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ $(GENERIC_DIR)/tclObj.c \ @@ -1101,9 +1100,6 @@ tclLoadShl.o: $(UNIX_DIR)/tclLoadShl.c tclMain.o: $(GENERIC_DIR)/tclMain.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclMain.c -tclMathOp.o: $(GENERIC_DIR)/tclMathOp.c $(MATHHDRS) - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclMathOp.c - tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c diff --git a/win/Makefile.in b/win/Makefile.in index ddcc921..53421e0 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.115 2007/03/23 18:45:40 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.115.2.1 2007/07/01 17:31:27 dgp Exp $ VERSION = @TCL_VERSION@ @@ -244,7 +244,6 @@ GENERIC_OBJS = \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMain.$(OBJEXT) \ - tclMathOp.$(OBJEXT) \ tclNamesp.$(OBJEXT) \ tclNotify.$(OBJEXT) \ tclObj.$(OBJEXT) \ diff --git a/win/makefile.bc b/win/makefile.bc index 81bba54..97846d6 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -231,7 +231,6 @@ TCLOBJS = \ $(TMPDIR)\tclListObj.obj \ $(TMPDIR)\tclLoad.obj \ $(TMPDIR)\tclMain.obj \ - $(TMPDIR)\tclMathOp.obj \ $(TMPDIR)\tclNamesp.obj \ $(TMPDIR)\tclNotify.obj \ $(TMPDIR)\tclObj.obj \ diff --git a/win/makefile.vc b/win/makefile.vc index 9f6830e..dbcb582 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -12,7 +12,7 @@ # Copyright (c) 2001-2004 David Gravereaux. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.160 2007/02/09 06:43:00 mistachkin Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.160.2.1 2007/07/01 17:31:27 dgp Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) @@ -291,7 +291,6 @@ TCLOBJS = \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ $(TMP_DIR)\tclMain.obj \ - $(TMP_DIR)\tclMathOp.obj \ $(TMP_DIR)\tclNamesp.obj \ $(TMP_DIR)\tclNotify.obj \ $(TMP_DIR)\tclObj.obj \ diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 7a276d4..c1b10da 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.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: tclWinFile.c,v 1.93 2007/05/05 07:23:18 dkf Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.93.2.1 2007/07/01 17:31:27 dgp Exp $ */ /* #define _WIN32_WINNT 0x0500 */ @@ -2322,84 +2322,6 @@ FromCTime( fileTime->dwHighDateTime = convertedTime.HighPart; } -#if 0 -/* - *------------------------------------------------------------------------- - * - * TclWinResolveShortcut -- - * - * Resolve a potential Windows shortcut to get the actual file or - * directory in question. - * - * Results: - * Returns 1 if the shortcut could be resolved, or 0 if there was an - * error or if the filename was not a shortcut. If bufferPtr did hold the - * name of a shortcut, it is modified to hold the resolved target of the - * shortcut instead. - * - * Side effects: - * Loads and unloads OLE package to determine if filename refers to a - * shortcut. - * - *------------------------------------------------------------------------- - */ - -int -TclWinResolveShortcut( - Tcl_DString *bufferPtr) /* Holds name of file to resolve. On return, - * holds resolved file name. */ -{ - HRESULT hres; - IShellLink *psl; - IPersistFile *ppf; - WIN32_FIND_DATA wfd; - WCHAR wpath[MAX_PATH]; - char *path, *ext; - char realFileName[MAX_PATH]; - - /* - * Windows system calls do not automatically resolve shortcuts like UNIX - * automatically will with symbolic links. - */ - - path = Tcl_DStringValue(bufferPtr); - ext = strrchr(path, '.'); - if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) { - return 0; - } - - CoInitialize(NULL); - path = Tcl_DStringValue(bufferPtr); - realFileName[0] = '\0'; - hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, - &IID_IShellLink, &psl); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf); - if (SUCCEEDED(hres)) { - MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath)); - hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->Resolve(psl,NULL,SLR_ANY_MATCH|SLR_NO_UI); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH, - &wfd, 0); - } - } - ppf->lpVtbl->Release(ppf); - } - psl->lpVtbl->Release(psl); - } - CoUninitialize(); - - if (realFileName[0] != '\0') { - Tcl_DStringSetLength(bufferPtr, 0); - Tcl_DStringAppend(bufferPtr, realFileName, -1); - return 1; - } - return 0; -} -#endif - /* *--------------------------------------------------------------------------- * -- cgit v0.12