summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog91
-rw-r--r--doc/DictObj.332
-rw-r--r--generic/tclAlloc.c48
-rw-r--r--generic/tclBasic.c189
-rw-r--r--generic/tclCmdIL.c20
-rw-r--r--generic/tclCompCmds.c4
-rw-r--r--generic/tclDate.c277
-rw-r--r--generic/tclExecute.c238
-rw-r--r--generic/tclFCmd.c4
-rw-r--r--generic/tclGetDate.y5
-rw-r--r--generic/tclIOCmd.c4
-rw-r--r--generic/tclInt.h37
-rw-r--r--generic/tclMathOp.c2884
-rw-r--r--generic/tclTestObj.c67
-rw-r--r--generic/tclThread.c20
-rwxr-xr-xgeneric/tclThreadAlloc.c102
-rw-r--r--generic/tclTrace.c4
-rw-r--r--macosx/README27
-rw-r--r--macosx/Tcl-Common.xcconfig3
-rw-r--r--macosx/Tcl.xcodeproj/default.pbxuser5
-rw-r--r--macosx/Tcl.xcodeproj/project.pbxproj57
-rw-r--r--unix/Makefile.in8
-rw-r--r--win/Makefile.in3
-rw-r--r--win/makefile.bc1
-rw-r--r--win/makefile.vc3
-rw-r--r--win/tclWinFile.c80
26 files changed, 476 insertions, 3737 deletions
diff --git a/ChangeLog b/ChangeLog
index f09f8a7..9e61c15 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,58 @@
+2007-06-30 Donal K. Fellows <dkf@users.sf.net>
+
+ * 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 <vasiljevic@users.sourceforge.net>
+
+ * 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 <dkf@users.sf.net>
+
+ * 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 <das@users.sourceforge.net>
+
+ * 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 <dgp@users.sourceforge.net>
+
+ * 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 <patthoyts@users.sourceforge.net>
+
+ * 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 <msofer@users.sf.net>
* generic/tclVar.c (UnsetVarStruct): fix possible segfault.
@@ -11,8 +66,8 @@
2007-06-26 Don Porter <dgp@users.sourceforge.net>
- * 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 <msofer@users.sf.net>
@@ -31,10 +86,10 @@
2007-06-24 Miguel Sofer <msofer@users.sf.net>
- * 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 <dgp@users.sourceforge.net>
* 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 <msofer@users.sf.net>
- * 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 <donal.k.fellows@man.ac.uk>
@@ -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 <dgp@users.sourceforge.net>
- * 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 <dkf@users.sf.net>
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 <stdlib.h> /* 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 <math.h>
-#include <float.h>
-
-/*
- * 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 <float.h>
-# else /* NO_FLOAT_H */
-# ifndef NO_VALUES_H
-# include <values.h>
-# 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<objc ; i++) {
- Tcl_Obj *resPtr = CombineIntFloat(interp, sumPtr, INST_ADD,
- objv[i]);
-
- if (resPtr == NULL) {
- TclDecrRefCount(sumPtr);
- return TCL_ERROR;
- }
- Tcl_IncrRefCount(resPtr);
- TclDecrRefCount(sumPtr);
- sumPtr = resPtr;
- }
- Tcl_SetObjResult(interp, sumPtr);
- Tcl_DecrRefCount(sumPtr); /* Public form since we know we won't
- * be freeing this object now. */
- return TCL_OK;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclMulOpCmd --
- *
- * 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
-TclMulOpCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- if (objc < 2) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
- 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_MULT,objv[2]);
- if (resPtr == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, resPtr);
- return TCL_OK;
- } else {
- Tcl_Obj *prodPtr = objv[1];
- int i;
-
- Tcl_IncrRefCount(prodPtr);
- for (i=2 ; i<objc ; i++) {
- Tcl_Obj *resPtr = CombineIntFloat(interp, prodPtr, INST_MULT,
- objv[i]);
-
- if (resPtr == NULL) {
- TclDecrRefCount(prodPtr);
- return TCL_ERROR;
- }
- Tcl_IncrRefCount(resPtr);
- TclDecrRefCount(prodPtr);
- prodPtr = resPtr;
- }
- Tcl_SetObjResult(interp, prodPtr);
- Tcl_DecrRefCount(prodPtr); /* Public form since we know we won't
- * be freeing this object now. */
- return TCL_OK;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclAndOpCmd --
- *
- * 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
-TclAndOpCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- if (objc < 2) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), -1);
- 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 = CombineIntOnly(interp, objv[1],INST_BITAND,objv[2]);
- if (resPtr == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, resPtr);
- return TCL_OK;
- } else {
- Tcl_Obj *accumPtr = objv[1];
- int i;
-
- Tcl_IncrRefCount(accumPtr);
- for (i=2 ; i<objc ; i++) {
- Tcl_Obj *resPtr = CombineIntOnly(interp, accumPtr, INST_BITAND,
- objv[i]);
-
- if (resPtr == NULL) {
- TclDecrRefCount(accumPtr);
- return TCL_ERROR;
- }
- Tcl_IncrRefCount(resPtr);
- TclDecrRefCount(accumPtr);
- accumPtr = resPtr;
- }
- Tcl_SetObjResult(interp, accumPtr);
- Tcl_DecrRefCount(accumPtr); /* Public form since we know we won't
- * be freeing this object now. */
- return TCL_OK;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclOrOpCmd --
- *
- * 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
-TclOrOpCmd(
- 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 = CombineIntOnly(interp, objv[1],INST_BITOR,objv[2]);
- if (resPtr == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, resPtr);
- return TCL_OK;
- } else {
- Tcl_Obj *accumPtr = objv[1];
- int i;
-
- Tcl_IncrRefCount(accumPtr);
- for (i=2 ; i<objc ; i++) {
- Tcl_Obj *resPtr = CombineIntOnly(interp, accumPtr, INST_BITOR,
- objv[i]);
-
- if (resPtr == NULL) {
- TclDecrRefCount(accumPtr);
- return TCL_ERROR;
- }
- Tcl_IncrRefCount(resPtr);
- TclDecrRefCount(accumPtr);
- accumPtr = resPtr;
- }
- Tcl_SetObjResult(interp, accumPtr);
- Tcl_DecrRefCount(accumPtr); /* Public form since we know we won't
- * be freeing this object now. */
- return TCL_OK;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclXorOpCmd --
- *
- * 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
-TclXorOpCmd(
- 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 = CombineIntOnly(interp, objv[1],INST_BITXOR,objv[2]);
- if (resPtr == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, resPtr);
- return TCL_OK;
- } else {
- Tcl_Obj *accumPtr = objv[1];
- int i;
-
- Tcl_IncrRefCount(accumPtr);
- for (i=2 ; i<objc ; i++) {
- Tcl_Obj *resPtr = CombineIntOnly(interp, accumPtr, INST_BITXOR,
- objv[i]);
-
- if (resPtr == NULL) {
- TclDecrRefCount(accumPtr);
- return TCL_ERROR;
- }
- Tcl_IncrRefCount(resPtr);
- TclDecrRefCount(accumPtr);
- accumPtr = resPtr;
- }
- Tcl_SetObjResult(interp, accumPtr);
- Tcl_DecrRefCount(accumPtr); /* Public form since we know we won't
- * be freeing this object now. */
- return TCL_OK;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclPowOpCmd --
- *
- * 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
-TclPowOpCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- if (objc < 2) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
- 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_EXPON,objv[2]);
- if (resPtr == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, resPtr);
- return TCL_OK;
- } else {
- Tcl_Obj *powPtr = objv[objc-1];
- int i;
-
- Tcl_IncrRefCount(powPtr);
- for (i=objc-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<objc ; i++) {
- Tcl_Obj *resPtr = CombineIntFloat(interp, diffPtr, INST_SUB,
- objv[i]);
-
- if (resPtr == NULL) {
- TclDecrRefCount(diffPtr);
- return TCL_ERROR;
- }
- Tcl_IncrRefCount(resPtr);
- TclDecrRefCount(diffPtr);
- diffPtr = resPtr;
- }
- Tcl_SetObjResult(interp, diffPtr);
- Tcl_DecrRefCount(diffPtr); /* Public form since we know we won't
- * be freeing this object now. */
- return TCL_OK;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclDivOpCmd --
- *
- * 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
-TclDivOpCmd(
- 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 reciprocal.
- */
-
- Tcl_Obj *onePtr = Tcl_NewDoubleObj(1.0);
- Tcl_Obj *resPtr;
-
- Tcl_IncrRefCount(onePtr);
- resPtr = CombineIntFloat(interp, onePtr, INST_DIV, objv[1]);
- if (resPtr == NULL) {
- TclDecrRefCount(onePtr);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, resPtr);
- TclDecrRefCount(onePtr);
- 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_DIV, objv[2]);
- if (resPtr == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, resPtr);
- return TCL_OK;
- } else {
- Tcl_Obj *numeratorPtr = objv[1];
- int i;
-
- Tcl_IncrRefCount(numeratorPtr);
- for (i=2 ; i<objc ; i++) {
- Tcl_Obj *resPtr = CombineIntFloat(interp, numeratorPtr, INST_DIV,
- objv[i]);
-
- if (resPtr == NULL) {
- TclDecrRefCount(numeratorPtr);
- return TCL_ERROR;
- }
- Tcl_IncrRefCount(resPtr);
- TclDecrRefCount(numeratorPtr);
- numeratorPtr = resPtr;
- }
- Tcl_SetObjResult(interp, numeratorPtr);
- Tcl_DecrRefCount(numeratorPtr); /* Public form since we know we won't
- * be freeing this object now. */
- return TCL_OK;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclLshiftOpCmd --
- *
- * 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
-TclLshiftOpCmd(
- 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;
- }
-
- /* Large left shifts create integer overflow */
- if ((type2 != TCL_NUMBER_LONG)
- || (*((const long *)ptr2) > (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<<shift));
- return TCL_OK;
- }
-
- /* Handle shifts within the native wide range */
- if ((type1 != TCL_NUMBER_BIG)
- && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
- Tcl_WideInt w;
-
- Tcl_GetWideIntFromObj(NULL, objv[1], &w);
- if (!(((w>0) ? w : ~w) & -(((Tcl_WideInt)1)
- << (CHAR_BIT*sizeof(Tcl_WideInt)-1-shift)))) {
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(w<<shift));
- return TCL_OK;
- }
- }
-
- {
- mp_int big, bigResult;
-
- Tcl_TakeBignumFromObj(NULL, objv[1], &big);
-
- mp_init(&bigResult);
- mp_mul_2d(&big, shift, &bigResult);
- 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclRshiftOpCmd --
- *
- * 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
-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<len ; i++) {
- s2 = Tcl_GetStringFromObj(listObj[i], &s2len);
- if (s1len == s2len && !strcmp(s1, s2)) {
- Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1);
- return TCL_OK;
- }
- }
- Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclNiOpCmd --
- *
- * This procedure is invoked to process the "::tcl::mathop::ni" Tcl
- * command. See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclNiOpCmd(
- 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<len ; i++) {
- s2 = Tcl_GetStringFromObj(listObj[i], &s2len);
- if (s1len == s2len && !strcmp(s1, s2)) {
- Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0);
- return TCL_OK;
- }
- }
- Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclLessOpCmd --
- *
- * 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
-TclLessOpCmd(
- 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<objc-1 ; i++) {
- switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) {
- case TCL_ERROR:
- /*
- * Got a string
- */
- str1 = Tcl_GetStringFromObj(objv[i], &len1);
- str2 = Tcl_GetStringFromObj(objv[i+1], &len2);
- if (TclpUtfNcmp2(str1, str2,
- (size_t) ((len1 < len2) ? len1 : len2)) >= 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<objc-1 ; i++) {
- switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) {
- case TCL_ERROR:
- /*
- * Got a string
- */
- str1 = Tcl_GetStringFromObj(objv[i], &len1);
- str2 = Tcl_GetStringFromObj(objv[i+1], &len2);
- if (TclpUtfNcmp2(str1, str2,
- (size_t) ((len1 < len2) ? len1 : len2)) > 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<objc-1 ; i++) {
- switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) {
- case TCL_ERROR:
- /*
- * Got a string
- */
- str1 = Tcl_GetStringFromObj(objv[i], &len1);
- str2 = Tcl_GetStringFromObj(objv[i+1], &len2);
- if (TclpUtfNcmp2(str1, str2,
- (size_t) ((len1 < len2) ? len1 : len2)) <= 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclGeqOpCmd --
- *
- * 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
-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<objc-1 ; i++) {
- switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) {
- case TCL_ERROR:
- /*
- * Got a string
- */
- str1 = Tcl_GetStringFromObj(objv[i], &len1);
- str2 = Tcl_GetStringFromObj(objv[i+1], &len2);
- if (TclpUtfNcmp2(str1, str2,
- (size_t) ((len1 < len2) ? len1 : len2)) < 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclEqOpCmd --
- *
- * 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
-TclEqOpCmd(
- 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<objc-1 ; i++) {
- switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) {
- case TCL_ERROR:
- /*
- * Got a string
- */
- str1 = Tcl_GetStringFromObj(objv[i], &len1);
- str2 = Tcl_GetStringFromObj(objv[i+1], &len2);
- if (len1 != len2 || strcmp(str1, str2)) {
- result = 0;
- i = objc;
- }
- continue;
- case TCL_OK:
- /*
- * Got proper numbers
- */
- if (cmp != MP_EQ) {
- 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclStreqOpCmd --
- *
- * This procedure is invoked to process the "::tcl::mathop::eq" Tcl
- * command. See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclStreqOpCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- int result = 1;
-
- if (objc > 2) {
- int i, len1, len2;
- const char *str1, *str2;
-
- for (i=1 ; i<objc-1 ; i++) {
- str1 = Tcl_GetStringFromObj(objv[i], &len1);
- str2 = Tcl_GetStringFromObj(objv[i+1], &len2);
- if (len1 != len2 || strcmp(str1, str2)) {
- result = 0;
- break;
- }
- }
- }
- Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result);
- return TCL_OK;
-}
-#endif
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 0553005..d6eeb6f 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.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: tclTestObj.c,v 1.19 2007/04/20 06:10:59 kennykb Exp $
+ * RCS: @(#) $Id: tclTestObj.c,v 1.19.2.1 2007/07/01 17:31:25 dgp Exp $
*/
#include "tclInt.h"
@@ -42,11 +42,6 @@ static int TestbignumobjCmd(ClientData dummy, Tcl_Interp *interp,
static int TestbooleanobjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-#if 0
-static int TestconvertobjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-#endif
static int TestdoubleobjCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int TestindexobjCmd(ClientData dummy, Tcl_Interp *interp,
@@ -97,10 +92,6 @@ TclObjTest_Init(
(ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
(ClientData) 0, NULL);
-#if 0
- Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
- (ClientData) 0, NULL);
-#endif
Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
(ClientData) 0, NULL);
Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
@@ -362,62 +353,6 @@ TestbooleanobjCmd(
return TCL_OK;
}
-#if 0
-/*
- *----------------------------------------------------------------------
- *
- * TestconvertobjCmd --
- *
- * This function implements the "testconvertobj" command. It is used to
- * test converting objects to new types.
- *
- * Results:
- * A standard Tcl object result.
- *
- * Side effects:
- * Converts objects to new types.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestconvertobjCmd(
- ClientData clientData, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- char *subCmd;
- char buf[20];
-
- if (objc < 3) {
- wrongNumArgs:
- Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
- return TCL_ERROR;
- }
-
- subCmd = Tcl_GetString(objv[1]);
- if (strcmp(subCmd, "double") == 0) {
- double d;
-
- if (objc != 3) {
- goto wrongNumArgs;
- }
- if (Tcl_GetDoubleFromObj(interp, objv[2], &d) != TCL_OK) {
- return TCL_ERROR;
- }
- sprintf(buf, "%f", d);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- } else {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad option \"", Tcl_GetString(objv[1]),
- "\": must be double", NULL);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-#endif
-
/*
*----------------------------------------------------------------------
*
diff --git a/generic/tclThread.c b/generic/tclThread.c
index 60c09ca..04d03d5 100644
--- a/generic/tclThread.c
+++ b/generic/tclThread.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: tclThread.c,v 1.16 2007/05/01 22:43:50 kennykb Exp $
+ * RCS: @(#) $Id: tclThread.c,v 1.16.2.1 2007/07/01 17:31:25 dgp Exp $
*/
#include "tclInt.h"
@@ -159,10 +159,21 @@ RememberSyncObject(
char **newList;
int i, j;
+
/*
- * Save the pointer to the allocated object so it can be finalized. Grow
- * the list of pointers if necessary, copying only non-NULL pointers to
- * the new list.
+ * Reuse any free slot in the list.
+ */
+
+ for (i=0 ; i < recPtr->num ; ++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 = "<group>"; };
- F9408AF20B195C08009F7CAC /* tclMathOp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclMathOp.c; sourceTree = "<group>"; };
F95FAFF90B34F1130072E431 /* macOSXLoad.test */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = macOSXLoad.test; sourceTree = "<group>"; };
F966C07408F2820D005CB29B /* CoreFoundation.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = CoreFoundation.framework; path = /System/Library/Frameworks/CoreFoundation.framework; sourceTree = "<absolute>"; };
F96D3DFA08F272A4004A47F5 /* ChangeLog */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = ChangeLog; sourceTree = "<group>"; };
@@ -933,7 +931,7 @@
F966C06F08F281DC005CB29B /* Frameworks */,
1AB674ADFE9D54B511CA2CBB /* Products */,
);
- comments = "Copyright (c) 2004-2007 Daniel A. Steffen <das@users.sourceforge.net>\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 <das@users.sourceforge.net>\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
-
/*
*---------------------------------------------------------------------------
*
generated by cgit v0.12 at 2025-09-15 13:30:39 (GMT)