Index: .project
==================================================================
--- .project
+++ .project
@@ -1,11 +1,11 @@
- tcl8.7
+ tcl8
DELETED compat/float.h
Index: compat/float.h
==================================================================
--- compat/float.h
+++ compat/float.h
@@ -1,14 +0,0 @@
-/*
- * float.h --
- *
- * This is a dummy header file to #include in Tcl when there
- * is no float.h in /usr/include. Right now this file is empty:
- * Tcl contains #ifdefs to deal with the lack of definitions;
- * all it needs is for the #include statement to work.
- *
- * Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
ADDED complex.txt
Index: complex.txt
==================================================================
--- complex.txt
+++ complex.txt
@@ -0,0 +1,59 @@
+Internal Representation:
+
+The internal rep of a complex number is two doubles.
+
+String Representation requirements:
+
+The canonical string rep of a complex number must be
+a valid list of one element.
+
+The canonical string rep of a complex number with
+zero imaginary part is equal to the same real number.
+
+The canonical string rep of a complex number with
+zero real part is the double plus the letter "i".
+
+The canonical string rep of a complex number probably needs to be
+distinguishable from an expression to allow it in unbraced expressions.
+(It could also be a valid parenthesised expression to yield the same result)
+
+String Representation:
+
+The canonical string rep of a complex number is the real part followed
+by an undercore and the imaginary part followed my the letter "i".
+
+Caveats:
+
+How about when the real part is negative? Unbraced $x might be different
+than {$x} when real(x) is negative since the leading minus becomes
+an unary negation. One possibility is to negate the imaginary part
+of the literal when the real part is negative. I.e. -1.0-5.0i would
+become -1.0_5.0i and -1.0+5.0i would become -1.0_-5.0i. Would work
+but would probably be totally confusing.
+(With a parenthesised format, the minus is inside and handled)
+
+Underscore Parenthesised String Rep
+ 0.0 0.0
+ 1.0 1.0
+ 1.0i 1.0i
+ -1.5i -1.5i
+ 1.0_1.5i (1.0+1.5i)
+ 1.0_-1.5i (1.0-1.5i)
+ -1.0_1.5i (-1.0+1.5i)
+ -2.0e10_2.0e-9i (-2.0e10+2.0e-9i)
+
+Should the single string "i" be valid? Maybe part of expression syntax?
+(Maybe not needed since 1i is allowed and fairly short)
+
+New functions:
+
+c=complex($r,$i)
+r=real($c)
+r=imag($c)
+r=abs($c) (magnitude)
+r=arg($c) (angle)
+c=polar($m,$a)
+c=conj($c) (conjugate)
+r=norm($c) (square of magnitude)
+
+Comparison operators can be defined to operate on the magnitude.
Index: doc/Object.3
==================================================================
--- doc/Object.3
+++ doc/Object.3
@@ -255,11 +255,11 @@
.PP
The \fBincr\fR command first gets an integer from \fIx\fR's value
by calling \fBTcl_GetIntFromObj\fR.
This procedure checks whether the value is already an integer value.
Since it is not, it converts the value
-by setting the value's \fIinternalRep.longValue\fR member
+by setting the value's internal representation
to the integer \fB123\fR
and setting the value's \fItypePtr\fR
to point to the integer Tcl_ObjType structure.
Both representations are now valid.
\fBincr\fR increments the value's integer internal representation
Index: doc/SaveResult.3
==================================================================
--- doc/SaveResult.3
+++ doc/SaveResult.3
@@ -52,13 +52,13 @@
state is to be restored. So long as one of the latter two routines
is called, Tcl will take care of memory management.
.PP
The second triplet stores the snapshot of only the interpreter
result (not its complete state) in memory allocated by the caller.
-These routines are passed a pointer to a \fBTcl_SavedResult\fR structure
+These routines are passed a pointer to \fBTcl_SavedResult\fR
that is used to store enough information to restore the interpreter result.
-This structure can be allocated on the stack of the calling
+\fBTcl_SavedResult\fR can be allocated on the stack of the calling
procedure. These routines do not save the state of any error
information in the interpreter (e.g. the \fB\-errorcode\fR or
\fB\-errorinfo\fR return options, when an error is in progress).
.PP
Because the routines \fBTcl_SaveInterpState\fR,
Index: generic/tcl.decls
==================================================================
--- generic/tcl.decls
+++ generic/tcl.decls
@@ -467,11 +467,10 @@
CONST84_RETURN char *Tcl_ErrnoMsg(int err)
}
declare 129 {
int Tcl_Eval(Tcl_Interp *interp, const char *script)
}
-# This is obsolete, use Tcl_FSEvalFile
declare 130 {
int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
declare 131 {
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
@@ -778,12 +777,11 @@
int Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr)
}
-# Obsolete
-declare 220 {
+declare 220 {deprecated {}} {
int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode)
}
declare 221 {
int Tcl_ServiceAll(void)
}
@@ -866,12 +864,11 @@
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}
declare 245 {
int Tcl_StringMatch(const char *str, const char *pattern)
}
-# Obsolete
-declare 246 {
+declare 246 {deprecated {}} {
int Tcl_TellOld(Tcl_Channel chan)
}
declare 247 {
int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
@@ -943,14 +940,14 @@
int Tcl_DumpActiveMemory(const char *fileName)
}
declare 266 {
void Tcl_ValidateAllMemory(const char *file, int line)
}
-declare 267 {
+declare 267 {deprecated {see TIP #422}} {
void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
-declare 268 {
+declare 268 {deprecated {see TIP #422}} {
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
@@ -974,20 +971,20 @@
# TIP #268: The internally used new Require function is in slot 573.
declare 274 {
CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
-declare 275 {
+declare 275 {deprecated {see TIP #422}} {
void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
-declare 276 {
+declare 276 {deprecated {see TIP #422}} {
int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)
}
declare 277 {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
-declare 278 {
+declare 278 {deprecated {see TIP #422}} {
TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList)
}
declare 279 {
void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type)
}
Index: generic/tcl.h
==================================================================
--- generic/tcl.h
+++ generic/tcl.h
@@ -1342,12 +1342,12 @@
*/
typedef struct {
void *next; /* Search position for underlying hash
* table. */
- int epoch; /* Epoch marker for dictionary being searched,
- * or -1 if search has terminated. */
+ unsigned int epoch; /* Epoch marker for dictionary being searched,
+ * or 0 if search has terminated. */
Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */
} Tcl_DictSearch;
/*
*----------------------------------------------------------------------------
@@ -2407,18 +2407,31 @@
int exact, int magic);
const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
const char *version, int epoch, int revision);
#ifdef USE_TCL_STUBS
-#define Tcl_InitStubs(interp, version, exact) \
- (Tcl_InitStubs)(interp, version, \
+#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
+# define Tcl_InitStubs(interp, version, exact) \
+ (Tcl_InitStubs)(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
TCL_STUB_MAGIC)
#else
-#define Tcl_InitStubs(interp, version, exact) \
- Tcl_PkgInitStubsCheck(interp, version, \
- (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
+# define Tcl_InitStubs(interp, version, exact) \
+ (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \
+ 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
+ TCL_STUB_MAGIC)
+#endif
+#else
+#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
+# define Tcl_InitStubs(interp, version, exact) \
+ Tcl_PkgInitStubsCheck(interp, version, \
+ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
+#else
+# define Tcl_InitStubs(interp, version, exact) \
+ Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \
+ 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
+#endif
#endif
/*
* Public functions that are not accessible via the stubs table.
* Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
Index: generic/tclBasic.c
==================================================================
--- generic/tclBasic.c
+++ generic/tclBasic.c
@@ -108,19 +108,28 @@
static Tcl_NRPostProc DTraceCmdReturn;
#else
# define DTraceCmdReturn NULL
#endif /* USE_DTRACE */
static Tcl_ObjCmdProc ExprAbsFunc;
+static Tcl_ObjCmdProc ExprArgFunc;
static Tcl_ObjCmdProc ExprBinaryFunc;
static Tcl_ObjCmdProc ExprBoolFunc;
static Tcl_ObjCmdProc ExprCeilFunc;
+static Tcl_ObjCmdProc ExprComplexFunc;
+static Tcl_ObjCmdProc ExprConjFunc;
static Tcl_ObjCmdProc ExprDoubleFunc;
static Tcl_ObjCmdProc ExprEntierFunc;
static Tcl_ObjCmdProc ExprFloorFunc;
+static Tcl_ObjCmdProc ExprImagFunc;
static Tcl_ObjCmdProc ExprIntFunc;
static Tcl_ObjCmdProc ExprIsqrtFunc;
+static Tcl_ObjCmdProc ExprMaxFunc;
+static Tcl_ObjCmdProc ExprMinFunc;
+static Tcl_ObjCmdProc ExprNormFunc;
+static Tcl_ObjCmdProc ExprPolarFunc;
static Tcl_ObjCmdProc ExprRandFunc;
+static Tcl_ObjCmdProc ExprRealFunc;
static Tcl_ObjCmdProc ExprRoundFunc;
static Tcl_ObjCmdProc ExprSqrtFunc;
static Tcl_ObjCmdProc ExprSrandFunc;
static Tcl_ObjCmdProc ExprUnaryFunc;
static Tcl_ObjCmdProc ExprWideFunc;
@@ -302,29 +311,38 @@
ClientData clientData; /* Client data for the function */
} BuiltinFuncDef;
static const BuiltinFuncDef BuiltinFuncTable[] = {
{ "abs", ExprAbsFunc, NULL },
{ "acos", ExprUnaryFunc, (ClientData) acos },
+ { "arg", ExprArgFunc, NULL },
{ "asin", ExprUnaryFunc, (ClientData) asin },
{ "atan", ExprUnaryFunc, (ClientData) atan },
{ "atan2", ExprBinaryFunc, (ClientData) atan2 },
{ "bool", ExprBoolFunc, NULL },
{ "ceil", ExprCeilFunc, NULL },
+ { "complex",ExprComplexFunc,NULL },
+ { "conj", ExprConjFunc, NULL },
{ "cos", ExprUnaryFunc, (ClientData) cos },
{ "cosh", ExprUnaryFunc, (ClientData) cosh },
{ "double", ExprDoubleFunc, NULL },
{ "entier", ExprEntierFunc, NULL },
{ "exp", ExprUnaryFunc, (ClientData) exp },
{ "floor", ExprFloorFunc, NULL },
{ "fmod", ExprBinaryFunc, (ClientData) fmod },
{ "hypot", ExprBinaryFunc, (ClientData) hypot },
+ { "imag", ExprImagFunc, NULL },
{ "int", ExprIntFunc, NULL },
{ "isqrt", ExprIsqrtFunc, NULL },
{ "log", ExprUnaryFunc, (ClientData) log },
{ "log10", ExprUnaryFunc, (ClientData) log10 },
+ { "max", ExprMaxFunc, NULL },
+ { "min", ExprMinFunc, NULL },
+ { "norm", ExprNormFunc, NULL },
+ { "polar", ExprPolarFunc, NULL },
{ "pow", ExprBinaryFunc, (ClientData) pow },
{ "rand", ExprRandFunc, NULL },
+ { "real", ExprRealFunc, NULL },
{ "round", ExprRoundFunc, NULL },
{ "sin", ExprUnaryFunc, (ClientData) sin },
{ "sinh", ExprUnaryFunc, (ClientData) sinh },
{ "sqrt", ExprSqrtFunc, NULL },
{ "srand", ExprSrandFunc, NULL },
@@ -2096,17 +2114,17 @@
tail = cmdName;
}
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
- if (isNew || deleted) {
+ if (isNew || deleted) {
/*
* isNew - No conflict with existing command.
* deleted - We've already deleted a conflicting command
*/
break;
- }
+ }
/* An existing command conflicts. Try to delete it.. */
cmdPtr = Tcl_GetHashValue(hPtr);
/*
@@ -2243,68 +2261,86 @@
* the global namespace. */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
ClientData clientData, /* Arbitrary value to pass to object
* function. */
- Tcl_CmdDeleteProc *deleteProc)
+ Tcl_CmdDeleteProc *deleteProc
/* If not NULL, gives a function to call when
* this command is deleted. */
+)
{
Interp *iPtr = (Interp *) interp;
- ImportRef *oldRefPtr = NULL;
Namespace *nsPtr;
- Command *cmdPtr;
- Tcl_HashEntry *hPtr;
const char *tail;
- int isNew = 0, deleted = 0;
- ImportedCmdData *dataPtr;
if (iPtr->flags & DELETED) {
/*
* The interpreter is being deleted. Don't create any new commands;
* it's not safe to muck with the interpreter anymore.
*/
-
return (Tcl_Command) NULL;
}
+ /*
+ * Determine where the command should reside. If its name contains
+ * namespace qualifiers, we put it in the specified namespace;
+ * otherwise, we always put it in the global namespace.
+ */
+
+ if (strstr(cmdName, "::") != NULL) {
+ Namespace *dummy1, *dummy2;
+
+ TclGetNamespaceForQualName(interp, cmdName, NULL,
+ TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
+ if ((nsPtr == NULL) || (tail == NULL)) {
+ return (Tcl_Command) NULL;
+ }
+ } else {
+ nsPtr = iPtr->globalNsPtr;
+ tail = cmdName;
+ }
+
+ return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr,
+ proc, clientData, deleteProc);
+}
+
+Tcl_Command
+TclCreateObjCommandInNs (
+ Tcl_Interp *interp,
+ const char *cmdName, /* Name of command, without any namespace components */
+ Tcl_Namespace *namespace, /* The namespace to create the command in */
+ Tcl_ObjCmdProc *proc, /* Object-based function to associate with
+ * name. */
+ ClientData clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+) {
+ int deleted = 0, isNew = 0;
+ Command *cmdPtr;
+ ImportRef *oldRefPtr = NULL;
+ ImportedCmdData *dataPtr;
+ Tcl_HashEntry *hPtr;
+ Namespace *nsPtr = (Namespace *) namespace;
/*
* If the command name we seek to create already exists, we need to
* delete that first. That can be tricky in the presence of traces.
* Loop until we no longer find an existing command in the way, or
* until we've deleted one command and that didn't finish the job.
*/
-
while (1) {
- /*
- * Determine where the command should reside. If its name contains
- * namespace qualifiers, we put it in the specified namespace;
- * otherwise, we always put it in the global namespace.
- */
-
- if (strstr(cmdName, "::") != NULL) {
- Namespace *dummy1, *dummy2;
-
- TclGetNamespaceForQualName(interp, cmdName, NULL,
- TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
- if ((nsPtr == NULL) || (tail == NULL)) {
- return (Tcl_Command) NULL;
- }
- } else {
- nsPtr = iPtr->globalNsPtr;
- tail = cmdName;
- }
-
- hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
-
- if (isNew || deleted) {
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
+
+ if (isNew || deleted) {
/*
* isNew - No conflict with existing command.
* deleted - We've already deleted a conflicting command
*/
break;
- }
+ }
+
/* An existing command conflicts. Try to delete it.. */
cmdPtr = Tcl_GetHashValue(hPtr);
/*
@@ -2333,21 +2369,26 @@
cmdPtr->refCount++;
if (cmdPtr->importRefPtr) {
cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
}
+
+ /* Make sure namespace doesn't get deallocated. */
+ cmdPtr->nsPtr->refCount++;
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+ nsPtr = (Namespace *) TclEnsureNamespace(interp,
+ (Tcl_Namespace *)cmdPtr->nsPtr);
+ TclNsDecrRefCount(cmdPtr->nsPtr);
if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
oldRefPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = NULL;
}
TclCleanupCommandMacro(cmdPtr);
deleted = 1;
}
-
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away
* the new command (if we try to delete it again, we could get
* stuck in an infinite loop).
@@ -2365,11 +2406,11 @@
* Without invalidating a possible CmdName literal here explicitly,
* such literals keep being reused while pointing to overhauled
* commands.
*/
- TclInvalidateCmdLiteral(interp, tail, nsPtr);
+ TclInvalidateCmdLiteral(interp, cmdName, nsPtr);
/*
* The list of command exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
@@ -6470,10 +6511,11 @@
case TCL_NUMBER_WIDE:
case TCL_NUMBER_BIG:
result = TclGetLongFromObj(interp, resultPtr, ptr);
break;
+ case TCL_NUMBER_COMPLEX:
case TCL_NUMBER_NAN:
Tcl_GetDoubleFromObj(interp, resultPtr, &d);
result = TCL_ERROR;
}
@@ -7173,10 +7215,63 @@
} else {
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
}
return TCL_OK;
}
+
+static int
+ExprImagFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Parameter vector. */
+{
+ ClientData ptr;
+ int type;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (type == TCL_NUMBER_COMPLEX) {
+ double *complex = *((double **) ptr);
+ double i = complex[1];
+
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(i));
+ return TCL_OK;
+ }
+
+ if (type == TCL_NUMBER_NAN) {
+#ifdef ACCEPT_NAN
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+#else
+ double d;
+ Tcl_GetDoubleFromObj(interp, objv[1], &d);
+ return TCL_ERROR;
+#endif
+ }
+
+ /*
+ * For all other types, the imaginary part is zero.
+ */
+
+ if (type == TCL_NUMBER_DOUBLE) {
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(0.0));
+ return TCL_OK;
+ }
+
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
+
+ return TCL_OK;
+}
static int
ExprIsqrtFunc(
ClientData clientData, /* Ignored */
Tcl_Interp *interp, /* The interpreter in which to execute. */
@@ -7207,10 +7302,11 @@
if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
switch (type) {
+ case TCL_NUMBER_COMPLEX: /* FIXME complex? */
case TCL_NUMBER_NAN:
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
case TCL_NUMBER_DOUBLE:
d = *((const double *) ptr);
@@ -7464,10 +7560,18 @@
goto tooLarge;
}
Tcl_SetObjResult(interp, Tcl_NewLongObj(-l));
return TCL_OK;
}
+
+ if (type == TCL_NUMBER_COMPLEX) {
+ double *complex = *((double **) ptr);
+ double d = sqrt(complex[0] * complex[0] + complex[1] * complex[1]);
+
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(d));
+ return TCL_OK;
+ }
if (type == TCL_NUMBER_DOUBLE) {
double d = *((const double *) ptr);
static const double poszero = 0.0;
@@ -7527,10 +7631,81 @@
return TCL_ERROR;
#endif
}
return TCL_OK;
}
+
+static int
+ExprArgFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Parameter vector. */
+{
+ ClientData ptr;
+ int type, isnegative = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (type == TCL_NUMBER_COMPLEX) {
+ double *complex = *((double **) ptr);
+ double d = atan2(complex[1], complex[0]);
+
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(d));
+ return TCL_OK;
+ }
+
+ if (type == TCL_NUMBER_NAN) {
+#ifdef ACCEPT_NAN
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+#else
+ double d;
+ Tcl_GetDoubleFromObj(interp, objv[1], &d);
+ return TCL_ERROR;
+#endif
+ }
+
+ /*
+ * For all other types, the angle is pi for negative, 0 otherwise.
+ */
+
+ if (type == TCL_NUMBER_LONG) {
+ long l = *((const long *) ptr);
+ if (l < 0) {
+ isnegative = 1;
+ }
+ }
+ if (type == TCL_NUMBER_DOUBLE) {
+ double d = *((const double *) ptr);
+ if (d < 0) {
+ isnegative = 1;
+ }
+ }
+ if (type == TCL_NUMBER_BIG) {
+ /* TODO: const correctness ? */
+ if (mp_cmp_d((mp_int *) ptr, 0) == MP_LT) {
+ isnegative = 1;
+ }
+ }
+
+ if (isnegative) {
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(atan2(0, -1)));
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(0.0));
+ }
+
+ return TCL_OK;
+}
static int
ExprBoolFunc(
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* The interpreter in which to execute the
@@ -7546,10 +7721,109 @@
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &value) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
+ return TCL_OK;
+}
+
+static int
+ExprComplexFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Parameter vector. */
+{
+ int code;
+ double d1, d2;
+ Tcl_Obj *result;
+
+ if (objc != 3) {
+ MathFuncWrongNumArgs(interp, 3, objc, objv);
+ return TCL_ERROR;
+ }
+ code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
+#ifdef ACCEPT_NAN
+ if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
+ d1 = objv[1]->internalRep.doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
+#endif
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
+#ifdef ACCEPT_NAN
+ if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) {
+ d2 = objv[2]->internalRep.doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
+#endif
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ errno = 0;
+
+ if (d2 == 0.0) {
+ TclNewDoubleObj(result, d1);
+ } else {
+ TclNewComplexObj(result, d1, d2);
+ }
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+}
+
+static int
+ExprConjFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Parameter vector. */
+{
+ ClientData ptr;
+ int type;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (type == TCL_NUMBER_COMPLEX) {
+ double *complex = *((double **) ptr);
+ double r = complex[0], i = complex[1];
+ Tcl_Obj *result;
+
+ TclNewComplexObj(result, r, -i);
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+ }
+
+ if (type == TCL_NUMBER_NAN) {
+#ifdef ACCEPT_NAN
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+#else
+ double d;
+ Tcl_GetDoubleFromObj(interp, objv[1], &d);
+ return TCL_ERROR;
+#endif
+ }
+
+ /*
+ * For all other types, the conjugate is itself.
+ */
+
+ Tcl_SetObjResult(interp, objv[1]);
+
return TCL_OK;
}
static int
ExprDoubleFunc(
@@ -7696,10 +7970,218 @@
Tcl_DecrRefCount(objPtr);
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
return TCL_OK;
}
+
+/*
+ * Common implmentation of max() and min().
+ */
+static int
+ExprMaxMinFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv, /* Actual parameter vector. */
+ int op) /* Comparison direction */
+{
+ Tcl_Obj *res;
+ double d;
+ int type, i;
+ ClientData ptr;
+
+ if (objc < 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+ res = objv[1];
+ for (i = 1; i < objc; i++) {
+ if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_NAN) {
+ /*
+ * Get the error message for NaN.
+ */
+
+ Tcl_GetDoubleFromObj(interp, objv[i], &d);
+ return TCL_ERROR;
+ }
+ if (TclCompareTwoNumbers(objv[i], res) == op) {
+ res = objv[i];
+ }
+ }
+
+ Tcl_SetObjResult(interp, res);
+ return TCL_OK;
+}
+
+static int
+ExprMaxFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Actual parameter vector. */
+{
+ return ExprMaxMinFunc(clientData, interp, objc, objv, MP_GT);
+}
+
+static int
+ExprMinFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Actual parameter vector. */
+{
+ return ExprMaxMinFunc(clientData, interp, objc, objv, MP_LT);
+}
+
+static int
+ExprNormFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Parameter vector. */
+{
+ ClientData ptr;
+ int type;
+ mp_int big;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (type == TCL_NUMBER_COMPLEX) {
+ double *complex = *((double **) ptr);
+ double d = complex[0] * complex[0] + complex[1] * complex[1];
+
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(d));
+ return TCL_OK;
+ }
+
+ if (type == TCL_NUMBER_DOUBLE) {
+ double d = *((const double *) ptr);
+
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(d * d));
+ return TCL_OK;
+ }
+
+ if (type == TCL_NUMBER_LONG) {
+ long l = *((const long *) ptr);
+ /* FIXME, overflow */
+ l = l * l;
+
+ if (l == LONG_MIN) {
+ TclBNInitBignumFromLong(&big, l);
+ goto tooLarge;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(l));
+ return TCL_OK;
+ }
+
+#ifndef NO_WIDE_TYPE
+ if (type == TCL_NUMBER_WIDE) {
+ Tcl_WideInt w = *((const Tcl_WideInt *) ptr);
+ /* FIXME, overflow */
+ w = w * w;
+
+ if (w == LLONG_MIN) {
+ TclBNInitBignumFromWideInt(&big, w);
+ goto tooLarge;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(w));
+ return TCL_OK;
+ }
+#endif
+
+ if (type == TCL_NUMBER_BIG) {
+ /* FIXME */
+ /* TODO: const correctness ? */
+ if (mp_cmp_d((mp_int *) ptr, 0) == MP_LT) {
+ Tcl_GetBignumFromObj(NULL, objv[1], &big);
+ tooLarge:
+ mp_neg(&big, &big);
+ Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
+ } else {
+ Tcl_SetObjResult(interp, objv[1]);
+ }
+ return TCL_OK;
+ }
+
+ if (type == TCL_NUMBER_NAN) {
+#ifdef ACCEPT_NAN
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+#else
+ double d;
+
+ Tcl_GetDoubleFromObj(interp, objv[1], &d);
+ return TCL_ERROR;
+#endif
+ }
+ return TCL_OK;
+}
+
+static int
+ExprPolarFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Parameter vector. */
+{
+ int code;
+ double d1, d2, r, i;
+ Tcl_Obj *result;
+
+ if (objc != 3) {
+ MathFuncWrongNumArgs(interp, 3, objc, objv);
+ return TCL_ERROR;
+ }
+ code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
+#ifdef ACCEPT_NAN
+ if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
+ d1 = objv[1]->internalRep.doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
+#endif
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
+#ifdef ACCEPT_NAN
+ if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) {
+ d2 = objv[2]->internalRep.doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
+#endif
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ errno = 0;
+
+ r = d1 * cos(d2);
+ i = d1 * sin(d2);
+ if (i == 0.0) {
+ TclNewDoubleObj(result, r);
+ } else {
+ TclNewComplexObj(result, r, i);
+ }
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+}
static int
ExprRandFunc(
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* The interpreter in which to execute the
@@ -7720,11 +8202,11 @@
if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
iPtr->flags |= RAND_SEED_INITIALIZED;
/*
- * To ensure different seeds in different threads (bug #416643),
+ * To ensure different seeds in different threads (bug #416643),
* take into consideration the thread this interp is running in.
*/
iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
@@ -7787,10 +8269,58 @@
* Push a Tcl object with the result.
*/
TclNewDoubleObj(oResult, dResult);
Tcl_SetObjResult(interp, oResult);
+ return TCL_OK;
+}
+
+static int
+ExprRealFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Parameter vector. */
+{
+ ClientData ptr;
+ int type;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (type == TCL_NUMBER_COMPLEX) {
+ double *complex = *((double **) ptr);
+ double d = complex[0];
+
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(d));
+ return TCL_OK;
+ }
+
+ if (type == TCL_NUMBER_NAN) {
+#ifdef ACCEPT_NAN
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+#else
+ double d;
+ Tcl_GetDoubleFromObj(interp, objv[1], &d);
+ return TCL_ERROR;
+#endif
+ }
+
+ /*
+ * For all other types, the real part is itself.
+ */
+
+ Tcl_SetObjResult(interp, objv[1]);
+
return TCL_OK;
}
static int
ExprRoundFunc(
@@ -8182,10 +8712,26 @@
* this command is deleted. */
{
Command *cmdPtr = (Command *)
Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc);
+ cmdPtr->nreProc = nreProc;
+ return (Tcl_Command) cmdPtr;
+}
+
+Tcl_Command
+TclNRCreateCommandInNs (
+ Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc,
+ Tcl_ObjCmdProc *nreProc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc) {
+ Command *cmdPtr = (Command *)
+ TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
+
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
}
/****************************************************************************
@@ -8970,48 +9516,35 @@
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Command *cmdPtr;
CoroutineData *corPtr;
- const char *fullName, *procName;
- Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
- Tcl_DString ds;
+ const char *procName, *simpleName;
+ Namespace *nsPtr, *altNsPtr, *cxtNsPtr,
+ *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
return TCL_ERROR;
}
- /*
- * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have
- * something in tclUtil.c to find the FQ name.
- */
-
- fullName = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, fullName, NULL, 0,
- &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+ procName = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, procName, inNsPtr, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
- fullName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL);
return TCL_ERROR;
}
- if (procName == NULL) {
+ if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
- fullName));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL);
- return TCL_ERROR;
- }
- if ((nsPtr != iPtr->globalNsPtr)
- && (procName != NULL) && (procName[0] == ':')) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create procedure \"%s\" in non-global namespace with"
- " name starting with \":\"", procName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL);
return TCL_ERROR;
}
/*
@@ -9019,20 +9552,13 @@
* struct and create the corresponding command.
*/
corPtr = ckalloc(sizeof(CoroutineData));
- Tcl_DStringInit(&ds);
- if (nsPtr != iPtr->globalNsPtr) {
- Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
- TclDStringAppendLiteral(&ds, "::");
- }
- Tcl_DStringAppend(&ds, procName, -1);
-
- cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
- /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine);
- Tcl_DStringFree(&ds);
+ cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName,
+ (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine,
+ corPtr, DeleteCoroutine);
corPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
/*
Index: generic/tclCmdMZ.c
==================================================================
--- generic/tclCmdMZ.c
+++ generic/tclCmdMZ.c
@@ -307,11 +307,11 @@
if (offset == 0) {
eflags = 0;
} else if (offset > stringLength) {
eflags = TCL_REG_NOTBOL;
- } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') {
+ } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
eflags = 0;
} else {
eflags = TCL_REG_NOTBOL;
}
@@ -1214,17 +1214,26 @@
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
+ int fullchar;
len = TclUtfToUniChar(stringPtr, &ch);
+ fullchar = ch;
+
+#if TCL_UTF_MAX == 4
+ if (!len) {
+ len += TclUtfToUniChar(stringPtr, &ch);
+ fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+ }
+#endif
/*
* Assume Tcl_UniChar is an integral type...
*/
- hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch),
+ hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(fullchar),
&isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
/*
@@ -1487,19 +1496,21 @@
int i, failat = 0, result = 1, strict = 0, index, length1, length2;
Tcl_Obj *objPtr, *failVarObj = NULL;
Tcl_WideInt w;
static const char *const isClasses[] = {
- "alnum", "alpha", "ascii", "control",
+ "alnum", "alpha", "ascii", "complex",
+ "control",
"boolean", "digit", "double", "entier",
"false", "graph", "integer", "list",
"lower", "print", "punct", "space",
"true", "upper", "wideinteger", "wordchar",
"xdigit", NULL
};
enum isClasses {
- STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
+ STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_COMPLEX,
+ STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
STR_IS_XDIGIT
@@ -1590,10 +1601,11 @@
chcomp = Tcl_UniCharIsControl;
break;
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
+ case STR_IS_COMPLEX:
case STR_IS_DOUBLE: {
/* TODO */
if ((objPtr->typePtr == &tclDoubleType) ||
(objPtr->typePtr == &tclIntType) ||
#ifndef TCL_WIDE_INT_IS_LONG
@@ -1617,10 +1629,13 @@
} else {
failat = stop - string1;
if (stop < end) {
result = 0;
TclFreeIntRep(objPtr);
+ } else if (objPtr->typePtr == &tclComplexType &&
+ index == STR_IS_DOUBLE) {
+ result = 0;
}
}
break;
}
case STR_IS_GRAPH:
@@ -1812,12 +1827,20 @@
}
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
+ int fullchar;
length2 = TclUtfToUniChar(string1, &ch);
- if (!chcomp(ch)) {
+ fullchar = ch;
+#if TCL_UTF_MAX == 4
+ if (!length2) {
+ length2 = TclUtfToUniChar(string1, &ch);
+ fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+ }
+#endif
+ if (!chcomp(fullchar)) {
result = 0;
break;
}
}
}
Index: generic/tclDecls.h
==================================================================
--- generic/tclDecls.h
+++ generic/tclDecls.h
@@ -667,11 +667,12 @@
EXTERN int Tcl_ScanElement(const char *src, int *flagPtr);
/* 219 */
EXTERN int Tcl_ScanCountedElement(const char *src, int length,
int *flagPtr);
/* 220 */
-EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode);
+TCL_DEPRECATED("")
+int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode);
/* 221 */
EXTERN int Tcl_ServiceAll(void);
/* 222 */
EXTERN int Tcl_ServiceEvent(int flags);
/* 223 */
@@ -739,11 +740,12 @@
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
/* 245 */
EXTERN int Tcl_StringMatch(const char *str, const char *pattern);
/* 246 */
-EXTERN int Tcl_TellOld(Tcl_Channel chan);
+TCL_DEPRECATED("")
+int Tcl_TellOld(Tcl_Channel chan);
/* 247 */
EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *proc,
ClientData clientData);
/* 248 */
@@ -810,14 +812,16 @@
/* 265 */
EXTERN int Tcl_DumpActiveMemory(const char *fileName);
/* 266 */
EXTERN void Tcl_ValidateAllMemory(const char *file, int line);
/* 267 */
-EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_AppendResultVA(Tcl_Interp *interp,
va_list argList);
/* 268 */
-EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
va_list argList);
/* 269 */
EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr);
/* 270 */
EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp,
@@ -836,18 +840,21 @@
/* 274 */
EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp,
const char *name, const char *version,
int exact);
/* 275 */
-EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
va_list argList);
/* 276 */
-EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList);
+TCL_DEPRECATED("see TIP #422")
+int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList);
/* 277 */
EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options);
/* 278 */
-EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList);
+TCL_DEPRECATED("see TIP #422")
+TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList);
/* 279 */
EXTERN void Tcl_GetVersion(int *major, int *minor,
int *patchLevel, int *type);
/* 280 */
EXTERN void Tcl_InitMemory(Tcl_Interp *interp);
@@ -2084,11 +2091,11 @@
void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */
void (*tcl_Release) (ClientData clientData); /* 216 */
void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */
int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */
int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */
- int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */
+ TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */
int (*tcl_ServiceAll) (void); /* 221 */
int (*tcl_ServiceEvent) (int flags); /* 222 */
void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */
void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */
int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */
@@ -2110,11 +2117,11 @@
void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */
int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */
void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */
void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
- int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
+ TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */
char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */
int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */
void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */
@@ -2131,22 +2138,22 @@
ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */
int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */
void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */
int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */
void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */
- void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */
- void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */
CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */
CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
- void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
- int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
+ TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */
- TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */
+ TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */
void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */
void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */
Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */
int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */
Index: generic/tclDictObj.c
==================================================================
--- generic/tclDictObj.c
+++ generic/tclDictObj.c
@@ -139,11 +139,11 @@
* created. */
ChainEntry *entryChainTail; /* Other end of linked list of all entries in
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
- int epoch; /* Epoch counter */
+ unsigned int epoch; /* Epoch counter */
size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
* dictionaries. */
} Dict;
@@ -388,11 +388,11 @@
/*
* Initialise other fields.
*/
- newDict->epoch = 0;
+ newDict->epoch = 1;
newDict->chain = NULL;
newDict->refCount = 1;
/*
* Store in the object.
@@ -485,19 +485,18 @@
static void
UpdateStringOfDict(
Tcl_Obj *dictPtr)
{
-#define LOCAL_SIZE 20
- int localFlags[LOCAL_SIZE], *flagPtr = NULL;
+#define LOCAL_SIZE 64
+ char localFlags[LOCAL_SIZE], *flagPtr = NULL;
Dict *dict = DICT(dictPtr);
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length, bytesNeeded = 0;
const char *elem;
char *dst;
- const int maxFlags = UINT_MAX / sizeof(int);
/*
* This field is the most useful one in the whole hash structure, and it
* is not exposed by any API function...
*/
@@ -515,14 +514,12 @@
* Pass 1: estimate space, gather flags.
*/
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
- } else if (numElems > maxFlags) {
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
} else {
- flagPtr = ckalloc(numElems * sizeof(int));
+ flagPtr = ckalloc(numElems);
}
for (i=0,cPtr=dict->entryChainHead; inextPtr) {
/*
* Assume that cPtr is never NULL since we know the number of array
* elements already.
@@ -708,11 +705,11 @@
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
TclFreeIntRep(objPtr);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DICT(objPtr) = dict;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclDictType;
@@ -1107,11 +1104,11 @@
}
dict = DICT(dictPtr);
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
- searchPtr->epoch = -1;
+ searchPtr->epoch = 0;
*donePtr = 1;
} else {
*donePtr = 0;
searchPtr->dictionaryPtr = (Tcl_Dict) dict;
searchPtr->epoch = dict->epoch;
@@ -1168,11 +1165,11 @@
/*
* If the searh is done; we do no work.
*/
- if (searchPtr->epoch == -1) {
+ if (!searchPtr->epoch) {
*donePtr = 1;
return;
}
/*
@@ -1225,12 +1222,12 @@
Tcl_DictObjDone(
Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */
{
Dict *dict;
- if (searchPtr->epoch != -1) {
- searchPtr->epoch = -1;
+ if (searchPtr->epoch) {
+ searchPtr->epoch = 0;
dict = (Dict *) searchPtr->dictionaryPtr;
if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
}
@@ -1378,11 +1375,11 @@
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DICT(dictPtr) = dict;
dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
@@ -1428,11 +1425,11 @@
TclDbNewObj(dictPtr, file, line);
TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DICT(dictPtr) = dict;
dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
Index: generic/tclEnsemble.c
==================================================================
--- generic/tclEnsemble.c
+++ generic/tclEnsemble.c
@@ -144,14 +144,16 @@
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Namespace *namespacePtr;
- Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+ Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
+ *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
Tcl_Command token;
Tcl_DictSearch search;
Tcl_Obj *listObj;
+ const char *simpleName;
int index, done;
if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -193,17 +195,12 @@
return TCL_ERROR;
}
objv += 2;
objc -= 2;
- /*
- * Work out what name to use for the command to create. If supplied,
- * it is either fully specified or relative to the current namespace.
- * If not supplied, it is exactly the name of the current namespace.
- */
-
- name = nsPtr->fullName;
+ name = nsPtr->name;
+ cxtPtr = (Namespace *) nsPtr->parentPtr;
/*
* Parse the option list, applying type checks as we go. Note that we
* are not incrementing any reference counts in the objects at this
* stage, so the presence of an option multiple times won't cause any
@@ -219,10 +216,11 @@
return TCL_ERROR;
}
switch ((enum EnsCreateOpts) index) {
case CRT_CMD:
name = TclGetString(objv[1]);
+ cxtPtr = nsPtr;
continue;
case CRT_SUBCMDS:
if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
@@ -335,19 +333,24 @@
unknownObj = (len > 0 ? objv[1] : NULL);
continue;
}
}
+ TclGetNamespaceForQualName(interp, name, cxtPtr,
+ TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr,
+ &simpleName);
+
/*
* Create the ensemble. Note that this might delete another ensemble
* linked to the same namespace, so we must be careful. However, we
* should be OK because we only link the namespace into the list once
* we've created it (and after any deletions have occurred.)
*/
- token = Tcl_CreateEnsemble(interp, name, NULL,
- (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
+ token = TclCreateEnsembleInNs(interp, simpleName,
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
+ (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
Tcl_SetEnsembleMappingDict(interp, token, mapObj);
Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
Tcl_SetEnsembleParameterList(interp, token, paramObj);
@@ -634,52 +637,42 @@
}
/*
*----------------------------------------------------------------------
*
- * Tcl_CreateEnsemble --
- *
- * Create a simple ensemble attached to the given namespace.
- *
- * Results:
- * The token for the command created.
- *
- * Side effects:
- * The ensemble is created and marked for compilation.
+ * TclCreateEnsembleInNs --
+ *
+ * Like Tcl_CreateEnsemble, but additionally accepts as an argument the
+ * name of the namespace to create the command in.
*
*----------------------------------------------------------------------
*/
Tcl_Command
-Tcl_CreateEnsemble(
- Tcl_Interp *interp,
- const char *name,
- Tcl_Namespace *namespacePtr,
- int flags)
-{
- Namespace *nsPtr = (Namespace *) namespacePtr;
- EnsembleConfig *ensemblePtr = ckalloc(sizeof(EnsembleConfig));
- Tcl_Obj *nameObj = NULL;
-
- if (nsPtr == NULL) {
- nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- }
-
- /*
- * Make the name of the ensemble into a fully qualified name. This might
- * allocate a temporary object.
- */
-
- if (!(name[0] == ':' && name[1] == ':')) {
- nameObj = NewNsObj((Tcl_Namespace *) nsPtr);
- if (nsPtr->parentPtr == NULL) {
- Tcl_AppendStringsToObj(nameObj, name, NULL);
- } else {
- Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
- }
- Tcl_IncrRefCount(nameObj);
- name = TclGetString(nameObj);
+TclCreateEnsembleInNs(
+ Tcl_Interp *interp,
+
+ const char *name, /* Simple name of command to create (no */
+ /* namespace components). */
+ Tcl_Namespace /* Name of namespace to create the command in. */
+ *nameNsPtr,
+ Tcl_Namespace
+ *ensembleNsPtr, /* Name of the namespace for the ensemble. */
+ int flags
+ )
+{
+ Namespace *nsPtr = (Namespace *) ensembleNsPtr;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Command token;
+
+ ensemblePtr = ckalloc(sizeof(EnsembleConfig));
+ token = TclNRCreateCommandInNs(interp, name,
+ (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd,
+ NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
+ if (token == NULL) {
+ ckfree(ensemblePtr);
+ return NULL;
}
ensemblePtr->nsPtr = nsPtr;
ensemblePtr->epoch = 0;
Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
@@ -688,13 +681,11 @@
ensemblePtr->subcommandDict = NULL;
ensemblePtr->flags = flags;
ensemblePtr->numParameters = 0;
ensemblePtr->parameterList = NULL;
ensemblePtr->unknownHandler = NULL;
- ensemblePtr->token = Tcl_NRCreateCommand(interp, name,
- NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR,
- ensemblePtr, DeleteEnsembleConfig);
+ ensemblePtr->token = token;
ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
/*
* Trigger an eventual recomputation of the ensemble command set. Note
@@ -707,15 +698,60 @@
if (flags & ENSEMBLE_COMPILE) {
((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
}
- if (nameObj != NULL) {
- TclDecrRefCount(nameObj);
- }
return ensemblePtr->token;
+
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateEnsemble
+ *
+ * Create a simple ensemble attached to the given namespace.
+ *
+ * Deprecated by TclCreateEnsembleInNs.
+ *
+ * Value
+ *
+ * The token for the command created.
+ *
+ * Effect
+ * The ensemble is created and marked for compilation.
+ *
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+Tcl_CreateEnsemble(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *namespacePtr,
+ int flags)
+{
+ Tcl_Obj *nameObj = NULL;
+ Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr,
+ *actualNsPtr;
+ const char * simpleName;
+
+ if (nsPtr == NULL) {
+ nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+ }
+
+ TclGetNamespaceForQualName(interp, name, nsPtr, 0,
+ &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
+ if (nameObj != NULL) {
+ TclDecrRefCount(nameObj);
+ }
+ return TclCreateEnsembleInNs(interp, simpleName,
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
}
+
/*
*----------------------------------------------------------------------
*
* Tcl_SetEnsembleSubcommandList --
@@ -1883,10 +1919,11 @@
* Hand off to the target command.
*/
TclSkipTailcall(interp);
Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv);
+ ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
}
unknownOrAmbiguousSubcommand:
/*
@@ -2503,10 +2540,11 @@
* the namespace that backs up this
* ensemble. */
int i, j, isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
+ Tcl_Obj *subcmdDictCopy = NULL ;
if (hash->numEntries != 0) {
/*
* Remove pre-existing table.
*/
@@ -2551,11 +2589,19 @@
/*
* Look in our dictionary (if present) for the command.
*/
if (ensemblePtr->subcommandDict != NULL) {
- Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
+ if (subcmdDictCopy == NULL) {
+ if (ensemblePtr->subcmdList == ensemblePtr->subcommandDict) {
+ subcmdDictCopy = Tcl_DuplicateObj(ensemblePtr->subcommandDict);
+ } else {
+ subcmdDictCopy = ensemblePtr->subcommandDict;
+ }
+ Tcl_IncrRefCount(subcmdDictCopy);
+ }
+ Tcl_DictObjGet(NULL, subcmdDictCopy, subcmdv[i],
&target);
if (target != NULL) {
Tcl_SetHashValue(hPtr, target);
Tcl_IncrRefCount(target);
continue;
@@ -2566,20 +2612,18 @@
* Not there, so map onto the namespace. Note in this case that we
* do not guarantee that the command is actually there; that is
* the programmer's responsibility (or [::unknown] of course).
*/
- cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr);
- if (ensemblePtr->nsPtr->parentPtr != NULL) {
- Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
- } else {
- Tcl_AppendStringsToObj(cmdObj, name, NULL);
- }
+ cmdObj = Tcl_NewStringObj(name, -1);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
}
+ if (subcmdDictCopy != NULL) {
+ Tcl_DecrRefCount(subcmdDictCopy);
+ }
} else if (ensemblePtr->subcommandDict != NULL) {
/*
* No subcmd list, but we do have a mapping dictionary so we should
* use the keys of that. Convert the dictionary's contents into the
* form required for the ensemble's internal hashtable.
@@ -2632,15 +2676,11 @@
*/
if (isNew) {
Tcl_Obj *cmdObj, *cmdPrefixObj;
- TclNewObj(cmdObj);
- Tcl_AppendStringsToObj(cmdObj,
- ensemblePtr->nsPtr->fullName,
- (ensemblePtr->nsPtr->parentPtr ? "::" : ""),
- nsCmdName, NULL);
+ cmdObj = Tcl_NewStringObj(nsCmdName, -1);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
}
break;
Index: generic/tclExecute.c
==================================================================
--- generic/tclExecute.c
+++ generic/tclExecute.c
@@ -742,12 +742,10 @@
#endif /* TCL_COMPILE_DEBUG */
static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void DeleteExecStack(ExecStack *esPtr);
static void DupExprCodeInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
-MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
- Tcl_Obj *value2Ptr);
static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp,
int opcode, Tcl_Obj **constants,
Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr);
static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode,
Tcl_Obj *valuePtr);
@@ -1331,16 +1329,16 @@
TclStackAlloc(
Tcl_Interp *interp,
int numBytes)
{
Interp *iPtr = (Interp *) interp;
- int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
+ int numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return (void *) ckalloc(numBytes);
}
-
+ numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
return (void *) StackAllocWords(interp, numWords);
}
void *
TclStackRealloc(
@@ -1906,18 +1904,20 @@
return TCL_OK;
}
#endif
}
- if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
+ if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN) ||
+ (type1 == TCL_NUMBER_COMPLEX)) {
/*
* Produce error message (reparse?!)
*/
return TclGetIntFromObj(interp, valuePtr, &type1);
}
- if ((type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) {
+ if ((type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN) ||
+ (type2 == TCL_NUMBER_COMPLEX)) {
/*
* Produce error message (reparse?!)
*/
TclGetIntFromObj(interp, incrPtr, &type1);
@@ -6020,10 +6020,11 @@
case INST_BITAND:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
+ || (type1 == TCL_NUMBER_COMPLEX)
|| (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
@@ -6031,10 +6032,11 @@
CACHE_STACK_INFO();
goto gotError;
}
if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK)
+ || (type2 == TCL_NUMBER_COMPLEX)
|| (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
@@ -6435,10 +6437,11 @@
case INST_BITNOT:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
+ || (type1 == TCL_NUMBER_COMPLEX)
|| (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) {
/*
* ... ~$NonInteger => raise an error.
*/
@@ -8152,10 +8155,18 @@
return objResultPtr; \
} else { \
Tcl_SetDoubleObj(valuePtr, (d)); \
return NULL; \
}
+#define COMPLEX_RESULT(d1, d2) \
+ if (Tcl_IsShared(valuePtr)) { \
+ TclNewComplexObj(objResultPtr, (d1), (d2)); \
+ return objResultPtr; \
+ } else { \
+ TclSetComplexObj(valuePtr, (d1), (d2)); \
+ return NULL; \
+ }
int type1, type2;
ClientData ptr1, ptr2;
double d1, d2, dResult;
long l1, l2, lResult;
@@ -8592,10 +8603,15 @@
case INST_EXPON: {
int oddExponent = 0, negativeExponent = 0;
unsigned short base;
+ if ((type1 == TCL_NUMBER_COMPLEX) || (type2 == TCL_NUMBER_COMPLEX)) {
+ /* FIXME complex */
+ dResult = 0.0;
+ goto doubleResult;
+ }
if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);
if (d1==0.0 && d2<0.0) {
@@ -8962,10 +8978,50 @@
case INST_ADD:
case INST_SUB:
case INST_MULT:
case INST_DIV:
+ if ((type1 == TCL_NUMBER_COMPLEX) || (type2 == TCL_NUMBER_COMPLEX)) {
+ double r1, r2, rResult;
+ double i1, i2, iResult;
+ double denom;
+
+ TclGetComplexFromObj(NULL, valuePtr, &r1, &i1);
+ TclGetComplexFromObj(NULL, value2Ptr, &r2, &i2);
+
+ switch (opcode) {
+ case INST_ADD:
+ rResult = r1 + r2;
+ iResult = i1 + i2;
+ break;
+ case INST_SUB:
+ rResult = r1 - r2;
+ iResult = i1 - i2;
+ break;
+ case INST_MULT:
+ rResult = r1 * r2 - i1 * i2;
+ iResult = r1 * i2 + r2 * i1;
+ break;
+ case INST_DIV:
+ denom = i1 * i1 + i2 * i2;
+ if (denom == 0.0) {
+ return DIVIDED_BY_ZERO;
+ }
+ rResult = (r1 * r2 + i1 * i2) / denom;
+ iResult = (r2 * i1 - r1 * i2) / denom;
+ break;
+ default:
+ /* Unused, here to silence compiler warning. */
+ rResult = 0;
+ iResult = 0;
+ }
+ if (iResult == 0.0) {
+ DOUBLE_RESULT(rResult);
+ } else {
+ COMPLEX_RESULT(rResult, iResult);
+ }
+ }
if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
/*
* At least one of the values is floating-point, so perform
* floating point calculations.
*/
@@ -9177,10 +9233,14 @@
BIG_RESULT(&big);
case INST_UMINUS:
switch (type) {
case TCL_NUMBER_DOUBLE:
DOUBLE_RESULT(-(*((const double *) ptr)));
+ case TCL_NUMBER_COMPLEX: {
+ double *complex = *((double **) ptr);
+ COMPLEX_RESULT(-complex[0], -complex[1]);
+ }
case TCL_NUMBER_LONG:
w = (Tcl_WideInt) (*((const long *) ptr));
if (w != LLONG_MIN) {
WIDE_RESULT(-w);
}
@@ -9239,10 +9299,11 @@
double d1, d2, tmp;
long l1, l2;
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w1, w2;
#endif
+ double *complex1, *complex2;
(void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
switch (type1) {
@@ -9292,10 +9353,20 @@
if (d2 > (double)LONG_MAX) {
return MP_LT;
}
l2 = (long) d2;
goto longCompare;
+ case TCL_NUMBER_COMPLEX:
+ /*
+ * Compare the square of magnitude, since it is easier and gives
+ * the same result as comparing magnitude.
+ */
+
+ d1 = (double) l1 * (double) l1;
+ complex2 = *((double **) ptr2);
+ d2 = complex2[0] * complex2[0] + complex2[1] * complex2[1];
+ goto doubleCompare;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
if (mp_cmp_d(&big2, 0) == MP_LT) {
compare = MP_GT;
} else {
@@ -9330,10 +9401,20 @@
if (d2 > (double)LLONG_MAX) {
return MP_LT;
}
w2 = (Tcl_WideInt) d2;
goto wideCompare;
+ case TCL_NUMBER_COMPLEX:
+ /*
+ * Compare the square of magnitude, since it is easier and gives
+ * the same result as comparing magnitude.
+ */
+
+ d1 = (double) w1 * (double) w1;
+ complex2 = *((double **) ptr2);
+ d2 = complex2[0] * complex2[0] + complex2[1] * complex2[1];
+ goto doubleCompare;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
if (mp_cmp_d(&big2, 0) == MP_LT) {
compare = MP_GT;
} else {
@@ -9349,10 +9430,20 @@
switch (type2) {
case TCL_NUMBER_DOUBLE:
d2 = *((const double *)ptr2);
doubleCompare:
return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
+ case TCL_NUMBER_COMPLEX:
+ /*
+ * Compare the square of magnitude, since it is easier and gives
+ * the same result as comparing magnitude.
+ */
+
+ d1 = d1 * d1;
+ complex2 = *((double **) ptr2);
+ d2 = complex2[0] * complex2[0] + complex2[1] * complex2[1];
+ 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) {
@@ -9435,17 +9526,94 @@
mp_clear(&big1);
goto doubleCompare;
}
Tcl_InitBignumFromDouble(NULL, d2, &big2);
goto bigCompare;
+ case TCL_NUMBER_COMPLEX:
+ /*
+ * Compare the square of magnitude, since it is easier and gives
+ * the same result as comparing magnitude.
+ */
+
+ d1 = TclBignumToDouble(&big1);
+ d1 = d1 * d1;
+ complex2 = *((double **) ptr2);
+ d2 = complex2[0] * complex2[0] + complex2[1] * complex2[1];
+ goto doubleCompare;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
bigCompare:
compare = mp_cmp(&big1, &big2);
mp_clear(&big1);
mp_clear(&big2);
return compare;
+ }
+ case TCL_NUMBER_COMPLEX:
+ complex1 = *((double **) ptr1);
+ d1 = sqrt(complex1[0] * complex1[0] + complex1[1] * complex1[1]);
+ switch (type2) {
+ case TCL_NUMBER_DOUBLE:
+ d2 = *((const double *)ptr2);
+ goto doubleCompare;
+ case TCL_NUMBER_COMPLEX:
+ complex2 = *((double **) ptr2);
+ d2 = sqrt(complex2[0] * complex2[0] + complex2[1] * complex2[1]);
+ 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) {
+ return MP_LT;
+ }
+ if (d1 > (double)LONG_MAX) {
+ return MP_GT;
+ }
+ l1 = (long) d1;
+ goto longCompare;
+#ifndef TCL_WIDE_INT_IS_LONG
+ 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) {
+ return MP_LT;
+ }
+ if (d1 > (double)LLONG_MAX) {
+ return MP_GT;
+ }
+ w1 = (Tcl_WideInt) d1;
+ goto wideCompare;
+#endif
+ case TCL_NUMBER_BIG:
+ if (TclIsInfinite(d1)) {
+ return (d1 > 0.0) ? MP_GT : MP_LT;
+ }
+ Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
+ if (mp_cmp_d(&big2, 0) == MP_LT) {
+ compare = MP_GT;
+ } else {
+ compare = MP_LT;
+ }
+ mp_clear(&big2);
+ return compare;
+ }
+ 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;
}
default:
Tcl_Panic("unexpected number type");
return TCL_ERROR;
}
@@ -9638,10 +9806,12 @@
}
} else if (type == TCL_NUMBER_NAN) {
description = "non-numeric floating-point value";
} else if (type == TCL_NUMBER_DOUBLE) {
description = "floating-point value";
+ } else if (type == TCL_NUMBER_COMPLEX) {
+ description = "complex value";
} else {
/* TODO: No caller needs this. Eliminate? */
description = "(big) integer";
}
Index: generic/tclHash.c
==================================================================
--- generic/tclHash.c
+++ generic/tclHash.c
@@ -983,15 +983,21 @@
static void
RebuildTable(
register Tcl_HashTable *tablePtr) /* Table to enlarge. */
{
- int oldSize, count, index;
- Tcl_HashEntry **oldBuckets;
+ int count, index, oldSize = tablePtr->numBuckets;
+ Tcl_HashEntry **oldBuckets = tablePtr->buckets;
register Tcl_HashEntry **oldChainPtr, **newChainPtr;
register Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
+
+ /* Avoid outgrowing capability of the memory allocators */
+ if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) {
+ tablePtr->rebuildSize = INT_MAX;
+ return;
+ }
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
@@ -1000,13 +1006,10 @@
typePtr = tablePtr->typePtr;
} else {
typePtr = &tclArrayHashKeyType;
}
- oldSize = tablePtr->numBuckets;
- oldBuckets = tablePtr->buckets;
-
/*
* Allocate and initialize the new bucket array, and set up hashing
* constants for new array size.
*/
Index: generic/tclIO.c
==================================================================
--- generic/tclIO.c
+++ generic/tclIO.c
@@ -9030,10 +9030,11 @@
* be marked busy.
*
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
int
TclCopyChannelOld(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Channel inChan, /* Channel to read from. */
Tcl_Channel outChan, /* Channel to write to. */
@@ -9041,10 +9042,11 @@
Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */
{
return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead,
cmdPtr);
}
+#endif
int
TclCopyChannel(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Channel inChan, /* Channel to read from. */
Index: generic/tclIOUtil.c
==================================================================
--- generic/tclIOUtil.c
+++ generic/tclIOUtil.c
@@ -410,11 +410,10 @@
TclDStringAppendObj(cwdPtr, cwd);
Tcl_DecrRefCount(cwd);
return Tcl_DStringValue(cwdPtr);
}
-/* Obsolete */
int
Tcl_EvalFile(
Tcl_Interp *interp, /* Interpreter in which to process file. */
const char *fileName) /* Name of file to process. Tilde-substitution
* will be performed on this name. */
Index: generic/tclIndexObj.c
==================================================================
--- generic/tclIndexObj.c
+++ generic/tclIndexObj.c
@@ -874,11 +874,12 @@
const char *message) /* Error message to print after the leading
* objects in objv. The message may be
* NULL. */
{
Tcl_Obj *objPtr;
- int i, len, elemLen, flags;
+ int i, len, elemLen;
+ char flags;
Interp *iPtr = (Interp *) interp;
const char *elementStr;
/*
* [incr Tcl] does something fairly horrific when generating error
Index: generic/tclInt.decls
==================================================================
--- generic/tclInt.decls
+++ generic/tclInt.decls
@@ -48,11 +48,11 @@
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
int TclCopyAndCollapse(int count, const char *src, char *dst)
}
-declare 8 {
+declare 8 {deprecated {}} {
int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan,
Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)
}
# TclCreatePipeline unofficially exported for use by BLT.
@@ -71,11 +71,11 @@
void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr)
}
declare 12 {
void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr)
}
-# Removed in 8.5
+# Removed in 8.5:
#declare 13 {
# int TclDoGlob(Tcl_Interp *interp, char *separators,
# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
#}
declare 14 {
@@ -86,11 +86,11 @@
# void TclExpandParseValue(ParseValue *pvPtr, int needed)
# }
declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
-# Removed in 8.4
+# Removed in 8.4:
#declare 17 {
# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
#}
#declare 18 {
# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
@@ -121,11 +121,11 @@
}
# Removed in 8.1:
# declare 26 {
# char *TclGetCwd(Tcl_Interp *interp)
# }
-# Removed in 8.5
+# Removed in 8.5:
#declare 27 {
# int TclGetDate(char *p, unsigned long now, long zone,
# unsigned long *timePtr)
#}
declare 28 {
@@ -145,11 +145,11 @@
}
declare 32 {
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
-# Removed in Tcl 8.5
+# Removed in 8.5:
#declare 33 {
# TclCmdProcType TclGetInterpProc(void)
#}
declare 34 {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -158,11 +158,11 @@
# Removed in 8.4b2:
#declare 35 {
# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
# int flags)
#}
-# Removed in 8.6a2
+# Removed in 8.6a2:
#declare 36 {
# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr)
#}
declare 37 {
int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName)
@@ -183,11 +183,11 @@
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 {
CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
}
-# Removed in Tcl 8.5a2
+# Removed in 8.5a2:
#declare 43 {
# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
# int flags)
#}
declare 44 {
@@ -218,11 +218,11 @@
Namespace *nsPtr)
}
declare 51 {
int TclInterpInit(Tcl_Interp *interp)
}
-# Removed in Tcl 8.5a2
+# Removed in 8.5a2:
#declare 52 {
# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
# int flags)
#}
declare 53 {
@@ -271,11 +271,11 @@
}
declare 64 {
int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
-# Removed in Tcl 8.5a2
+# Removed in 8.5a2:
#declare 65 {
# int TclObjInvokeGlobal(Tcl_Interp *interp, int objc,
# Tcl_Obj *const objv[], int flags)
#}
#declare 66 {
@@ -311,13 +311,11 @@
unsigned long TclpGetClicks(void)
}
declare 76 {
unsigned long TclpGetSeconds(void)
}
-
-# deprecated
-declare 77 {
+declare 77 {deprecated {}} {
void TclpGetTime(Tcl_Time *time)
}
# Removed in 8.6:
#declare 78 {
# int TclpGetTimeZone(unsigned long time)
@@ -378,11 +376,11 @@
const char *procName)
}
declare 93 {
void TclProcDeleteProc(ClientData clientData)
}
-# Removed in Tcl 8.5:
+# Removed in 8.5:
#declare 94 {
# int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp,
# int argc, const char **argv)
#}
# Replaced by Tcl_FSStat in 8.4:
@@ -417,11 +415,11 @@
}
declare 103 {
int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto,
int *portPtr)
}
-declare 104 {
+declare 104 {deprecated {}} {
int TclSockMinimumBuffersOld(int sock, int size)
}
# Replaced by Tcl_FSStat in 8.4:
#declare 105 {
# int TclStat(const char *path, Tcl_StatBuf *buf)
@@ -453,30 +451,30 @@
void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 112 {
- int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
}
declare 113 {
- Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
+ Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name,
ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 114 {
- void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
+ void TclDeleteNamespace(Tcl_Namespace *nsPtr)
}
declare 115 {
- int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst)
}
declare 116 {
- Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
+ Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 117 {
- Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name,
+ Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 118 {
int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolverInfo *resInfo)
@@ -488,32 +486,32 @@
declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 121 {
- int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern)
}
declare 122 {
- Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
+ Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 123 {
- void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
+ void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
Tcl_Obj *objPtr)
}
declare 124 {
- Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp)
+ Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp)
}
declare 125 {
- Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp)
+ Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp)
}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
declare 127 {
- int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite)
}
declare 128 {
void Tcl_PopCallFrame(Tcl_Interp *interp)
}
@@ -530,11 +528,11 @@
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 132 {
int TclpHasSockets(Tcl_Interp *interp)
}
-declare 133 {
+declare 133 {deprecated {}} {
struct tm *TclpGetDate(const time_t *time, int useGMT)
}
# Removed in 8.5
#declare 134 {
# size_t TclpStrftime(char *s, size_t maxsize, const char *format,
@@ -623,16 +621,14 @@
int status)
}
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
-# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
-declare 158 {
+declare 158 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptFileName(const char *filename)
}
-# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
-declare 159 {
+declare 159 {deprecated {use public Tcl_GetStartupScript()}} {
const char *TclGetStartupScriptFileName(void)
}
#declare 160 {
# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
# Tcl_DString *dirPtr, char *pattern, char *tail,
@@ -674,17 +670,14 @@
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
int index, Tcl_Obj *valuePtr)
}
-# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
-# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
-declare 167 {
+declare 167 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
}
-# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
-declare 168 {
+declare 168 {deprecated {use public Tcl_GetStartupScript()}} {
Tcl_Obj *TclGetStartupScriptPath(void)
}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 {
int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n)
@@ -728,16 +721,15 @@
}
declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
-# TIP 338 made these public - now declared in tcl.h too
declare 178 {
- void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
+ void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
}
declare 179 {
- Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
+ Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr)
}
# REMOVED
# Allocate lists without copying arrays
# declare 180 {
@@ -746,16 +738,14 @@
#declare 181 {
# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv,
# const char *file, int line)
#}
-# TclpGmtime and TclpLocaltime promoted to the generic interface from unix
-
-declare 182 {
+declare 182 {deprecated {}} {
struct tm *TclpLocaltime(const time_t *clock)
}
-declare 183 {
+declare 183 {deprecated {}} {
struct tm *TclpGmtime(const time_t *clock)
}
# For the new "Thread Storage" subsystem.
@@ -935,14 +925,11 @@
int *newPtr)
}
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
-
-
-# TIP 337 made this one public
-declare 236 {
+declare 236 {deprecated {use Tcl_BackgroundException}} {
void TclBackgroundException(Tcl_Interp *interp, int code)
}
# TIP #285: Script cancellation support.
declare 237 {
@@ -1088,11 +1075,11 @@
}
# new for 8.4.20+/8.5.12+ Cygwin only
declare 10 win {
Tcl_DirEntry *TclpReaddir(DIR *dir)
}
-# Removed in 8.3.1 (for Win32s only)
+# Removed in 8.3.1 (for Win32s only):
#declare 10 win {
# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
#}
# Pipe channel functions
@@ -1138,11 +1125,10 @@
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
void TclWinAddProcess(HANDLE hProcess, DWORD id)
}
-# new for 8.4.20+/8.5.12+
declare 21 win {
char *TclpInetNtoa(struct in_addr addr)
}
# removed permanently for 8.4
#declare 21 win {
Index: generic/tclInt.h
==================================================================
--- generic/tclInt.h
+++ generic/tclInt.h
@@ -2686,10 +2686,11 @@
#define TCL_NUMBER_LONG 1
#define TCL_NUMBER_WIDE 2
#define TCL_NUMBER_BIG 3
#define TCL_NUMBER_DOUBLE 4
#define TCL_NUMBER_NAN 5
+#define TCL_NUMBER_COMPLEX 6
/*
*----------------------------------------------------------------
* Variables shared among Tcl modules but not used by the outside world.
*----------------------------------------------------------------
@@ -2719,10 +2720,11 @@
MODULE_SCOPE const Tcl_ObjType tclBignumType;
MODULE_SCOPE const Tcl_ObjType tclBooleanType;
MODULE_SCOPE const Tcl_ObjType tclByteArrayType;
MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
MODULE_SCOPE const Tcl_ObjType tclDoubleType;
+MODULE_SCOPE const Tcl_ObjType tclComplexType;
MODULE_SCOPE const Tcl_ObjType tclEndOffsetType;
MODULE_SCOPE const Tcl_ObjType tclIntType;
MODULE_SCOPE const Tcl_ObjType tclListType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
@@ -2906,25 +2908,40 @@
const char *value);
MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
+MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
+ Tcl_Obj *value2Ptr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
int *loc);
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
int start, int *clNext);
MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr);
MODULE_SCOPE int TclConvertElement(const char *src, int length,
char *dst, int flags);
+MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs (
+ Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *nameNamespacePtr,
+ Tcl_Namespace *ensembleNamespacePtr,
+ int flags);
MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp,
const char *dict, int dictLength,
const char **elementPtr, const char **nextPtr,
int *sizePtr, int *literalPtr);
-/* TIP #280 - Modified token based evulation, with line information. */
+/* TIP #280 - Modified token based evaluation, with line information. */
MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
int numBytes, int flags, int line,
int *clNextOuter, const char *outerScript);
MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
@@ -2943,10 +2960,14 @@
MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr,
Tcl_DString *toAppendPtr);
MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr);
MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp,
Tcl_Obj *const *objv, int objc, int *objcPtr);
+Tcl_Namespace * TclEnsureNamespace(
+ Tcl_Interp *interp,
+ Tcl_Namespace *namespacePtr);
+
MODULE_SCOPE void TclFinalizeAllocSubsystem(void);
MODULE_SCOPE void TclFinalizeAsync(void);
MODULE_SCOPE void TclFinalizeDoubleConversion(void);
MODULE_SCOPE void TclFinalizeEncodingSubsystem(void);
MODULE_SCOPE void TclFinalizeEnvironment(void);
@@ -2969,10 +2990,19 @@
MODULE_SCOPE void TclFinalizeThreadObjects(void);
MODULE_SCOPE double TclFloor(const mp_int *a);
MODULE_SCOPE void TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr,
const char *attributeName, int *indexPtr);
+MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs (
+ Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc,
+ Tcl_ObjCmdProc *nreProc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+
MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
const char *encodingName);
MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
MODULE_SCOPE int * TclGetAsyncReadyPtr(void);
MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp);
@@ -2980,10 +3010,12 @@
Tcl_Obj *objPtr, Tcl_Channel *chanPtr,
int *modePtr, int flags);
MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr);
MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp,
Tcl_Obj *value, int *code);
+MODULE_SCOPE int TclGetComplexFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, double *realPtr, double *imagPtr);
MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, ClientData *clientDataPtr,
int *typePtr);
MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp,
const char *modeString, int *seekFlagPtr,
@@ -3143,11 +3175,11 @@
MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr,
int reStrLen, Tcl_DString *dsPtr, int *flagsPtr,
int *quantifiersFoundPtr);
MODULE_SCOPE int TclScanElement(const char *string, int length,
- int *flagPtr);
+ char *flagPtr);
MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp,
Tcl_Obj *cmdPrefix);
MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr,
mp_int *bignumValue);
MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
@@ -4481,11 +4513,11 @@
# define TclUniCharNcmp Tcl_UniCharNcmp
#endif /* WORDS_BIGENDIAN */
/*
*----------------------------------------------------------------
- * Macro used by the Tcl core to increment a namespace's export export epoch
+ * Macro used by the Tcl core to increment a namespace's export epoch
* counter. The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr);
*----------------------------------------------------------------
*/
@@ -4573,10 +4605,18 @@
TclFreeIntRep(objPtr); \
(objPtr)->internalRep.doubleValue = (double)(d); \
(objPtr)->typePtr = &tclDoubleType; \
} while (0)
+#define TclSetComplexObj(objPtr, r, i) \
+ TclInvalidateStringRep(objPtr);\
+ TclFreeIntRep(objPtr); \
+ (objPtr)->internalRep.otherValuePtr = ckalloc(sizeof(double) * 2); \
+ ((double *)((objPtr)->internalRep.otherValuePtr))[0] = (double)(r); \
+ ((double *)((objPtr)->internalRep.otherValuePtr))[1] = (double)(i); \
+ (objPtr)->typePtr = &tclComplexType
+
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and initialise objects of standard
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
@@ -4638,10 +4678,21 @@
* The sLiteral argument *must* be a string literal; the incantation with
* sizeof(sLiteral "") will fail to compile otherwise.
*/
#define TclNewLiteralStringObj(objPtr, sLiteral) \
TclNewStringObj((objPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
+
+#define TclNewComplexObj(objPtr, r, i) \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ (objPtr)->bytes = NULL; \
+ (objPtr)->internalRep.otherValuePtr = ckalloc(sizeof(double) * 2); \
+ ((double *)((objPtr)->internalRep.otherValuePtr))[0] = (double)(r); \
+ ((double *)((objPtr)->internalRep.otherValuePtr))[1] = (double)(i); \
+ (objPtr)->typePtr = &tclComplexType; \
+ TCL_DTRACE_OBJ_CREATE(objPtr)
/*
*----------------------------------------------------------------
* Convenience macros for DStrings.
* The ANSI C "prototypes" for these macros are:
Index: generic/tclIntDecls.h
==================================================================
--- generic/tclIntDecls.h
+++ generic/tclIntDecls.h
@@ -26,26 +26,10 @@
# else
# define TCL_STORAGE_CLASS DLLIMPORT
# endif
#endif
-/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */
-#undef Tcl_CreateNamespace
-#undef Tcl_DeleteNamespace
-#undef Tcl_AppendExportList
-#undef Tcl_Export
-#undef Tcl_Import
-#undef Tcl_ForgetImport
-#undef Tcl_GetCurrentNamespace
-#undef Tcl_GetGlobalNamespace
-#undef Tcl_FindNamespace
-#undef Tcl_FindCommand
-#undef Tcl_GetCommandFromObj
-#undef Tcl_GetCommandFullName
-#undef Tcl_SetStartupScript
-#undef Tcl_GetStartupScript
-
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
* script. Any modifications to the function declarations below should be made
* in the generic/tclInt.decls script.
*/
@@ -73,11 +57,12 @@
EXTERN void TclCleanupCommand(Command *cmdPtr);
/* 7 */
EXTERN int TclCopyAndCollapse(int count, const char *src,
char *dst);
/* 8 */
-EXTERN int TclCopyChannelOld(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+int TclCopyChannelOld(Tcl_Interp *interp,
Tcl_Channel inChan, Tcl_Channel outChan,
int toRead, Tcl_Obj *cmdPtr);
/* 9 */
EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc,
const char **argv, Tcl_Pid **pidArrayPtr,
@@ -216,11 +201,12 @@
/* 75 */
EXTERN unsigned long TclpGetClicks(void);
/* 76 */
EXTERN unsigned long TclpGetSeconds(void);
/* 77 */
-EXTERN void TclpGetTime(Tcl_Time *time);
+TCL_DEPRECATED("")
+void TclpGetTime(Tcl_Time *time);
/* Slot 78 is reserved */
/* Slot 79 is reserved */
/* Slot 80 is reserved */
/* 81 */
EXTERN char * TclpRealloc(char *ptr, unsigned int size);
@@ -265,11 +251,12 @@
EXTERN void TclSetupEnv(Tcl_Interp *interp);
/* 103 */
EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str,
const char *proto, int *portPtr);
/* 104 */
-EXTERN int TclSockMinimumBuffersOld(int sock, int size);
+TCL_DEPRECATED("")
+int TclSockMinimumBuffersOld(int sock, int size);
/* Slot 105 is reserved */
/* Slot 106 is reserved */
/* Slot 107 is reserved */
/* 108 */
EXTERN void TclTeardownNamespace(Namespace *nsPtr);
@@ -282,26 +269,26 @@
const char *name,
Tcl_ResolveCmdProc *cmdProc,
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 112 */
-EXTERN int Tcl_AppendExportList(Tcl_Interp *interp,
+EXTERN int TclAppendExportList(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, Tcl_Obj *objPtr);
/* 113 */
-EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp,
+EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp,
const char *name, ClientData clientData,
Tcl_NamespaceDeleteProc *deleteProc);
/* 114 */
-EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr);
+EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr);
/* 115 */
-EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst);
/* 116 */
-EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
+EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 117 */
-EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp,
+EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 118 */
EXTERN int Tcl_GetInterpResolvers(Tcl_Interp *interp,
const char *name, Tcl_ResolverInfo *resInfo);
@@ -312,27 +299,27 @@
/* 120 */
EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 121 */
-EXTERN int Tcl_ForgetImport(Tcl_Interp *interp,
+EXTERN int TclForgetImport(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, const char *pattern);
/* 122 */
-EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp,
+EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 123 */
-EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp,
+EXTERN void TclGetCommandFullName(Tcl_Interp *interp,
Tcl_Command command, Tcl_Obj *objPtr);
/* 124 */
-EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp);
+EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp);
/* 125 */
-EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp);
+EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp);
/* 126 */
EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp,
Tcl_Var variable, Tcl_Obj *objPtr);
/* 127 */
-EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite);
/* 128 */
EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp);
/* 129 */
EXTERN int Tcl_PushCallFrame(Tcl_Interp *interp,
@@ -348,11 +335,12 @@
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 132 */
EXTERN int TclpHasSockets(Tcl_Interp *interp);
/* 133 */
-EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT);
+TCL_DEPRECATED("")
+struct tm * TclpGetDate(const time_t *time, int useGMT);
/* Slot 134 is reserved */
/* Slot 135 is reserved */
/* Slot 136 is reserved */
/* Slot 137 is reserved */
/* 138 */
@@ -399,13 +387,15 @@
int status);
/* 157 */
EXTERN Var * TclVarTraceExists(Tcl_Interp *interp,
const char *varName);
/* 158 */
-EXTERN void TclSetStartupScriptFileName(const char *filename);
+TCL_DEPRECATED("use public Tcl_SetStartupScript()")
+void TclSetStartupScriptFileName(const char *filename);
/* 159 */
-EXTERN const char * TclGetStartupScriptFileName(void);
+TCL_DEPRECATED("use public Tcl_GetStartupScript()")
+const char * TclGetStartupScriptFileName(void);
/* Slot 160 is reserved */
/* 161 */
EXTERN int TclChannelTransform(Tcl_Interp *interp,
Tcl_Channel chan, Tcl_Obj *cmdObjPtr);
/* 162 */
@@ -420,13 +410,15 @@
/* 166 */
EXTERN int TclListObjSetElement(Tcl_Interp *interp,
Tcl_Obj *listPtr, int index,
Tcl_Obj *valuePtr);
/* 167 */
-EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
+TCL_DEPRECATED("use public Tcl_SetStartupScript()")
+void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
/* 168 */
-EXTERN Tcl_Obj * TclGetStartupScriptPath(void);
+TCL_DEPRECATED("use public Tcl_GetStartupScript()")
+Tcl_Obj * TclGetStartupScriptPath(void);
/* 169 */
EXTERN int TclpUtfNcmp2(const char *s1, const char *s2,
unsigned long n);
/* 170 */
EXTERN int TclCheckInterpTraces(Tcl_Interp *interp,
@@ -455,20 +447,22 @@
/* 177 */
EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1,
const char *part2, const char *operation,
const char *reason);
/* 178 */
-EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr,
+EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr,
const char *encodingName);
/* 179 */
-EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr);
+EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr);
/* Slot 180 is reserved */
/* Slot 181 is reserved */
/* 182 */
-EXTERN struct tm * TclpLocaltime(const time_t *clock);
+TCL_DEPRECATED("")
+struct tm * TclpLocaltime(const time_t *clock);
/* 183 */
-EXTERN struct tm * TclpGmtime(const time_t *clock);
+TCL_DEPRECATED("")
+struct tm * TclpGmtime(const time_t *clock);
/* Slot 184 is reserved */
/* Slot 185 is reserved */
/* Slot 186 is reserved */
/* Slot 187 is reserved */
/* Slot 188 is reserved */
@@ -568,11 +562,12 @@
const char *key, int *newPtr);
/* 235 */
EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr,
Namespace *nsPtr);
/* 236 */
-EXTERN void TclBackgroundException(Tcl_Interp *interp, int code);
+TCL_DEPRECATED("use Tcl_BackgroundException")
+void TclBackgroundException(Tcl_Interp *interp, int code);
/* 237 */
EXTERN int TclResetCancellation(Tcl_Interp *interp, int force);
/* 238 */
EXTERN int TclNRInterpProc(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -650,11 +645,11 @@
void (*tclAllocateFreeObjects) (void); /* 3 */
void (*reserved4)(void);
int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */
int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */
- int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */
+ TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */
int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */
int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */
void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */
void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */
void (*reserved13)(void);
@@ -719,11 +714,11 @@
void (*reserved72)(void);
void (*reserved73)(void);
void (*tclpFree) (char *ptr); /* 74 */
unsigned long (*tclpGetClicks) (void); /* 75 */
unsigned long (*tclpGetSeconds) (void); /* 76 */
- void (*tclpGetTime) (Tcl_Time *time); /* 77 */
+ TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */
void (*reserved78)(void);
void (*reserved79)(void);
void (*reserved80)(void);
char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */
void (*reserved82)(void);
@@ -746,40 +741,40 @@
void (*reserved99)(void);
void (*reserved100)(void);
CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */
void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */
int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */
- int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */
+ TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */
void (*reserved105)(void);
void (*reserved106)(void);
void (*reserved107)(void);
void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */
int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */
int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */
void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */
- int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
- Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
- void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
- int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
- Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
- Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */
+ int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
+ Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
+ void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
+ int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
+ Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
+ Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */
int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */
int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */
Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */
- int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
- Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
- void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
- Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */
- Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */
+ int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
+ Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
+ void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
+ Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */
+ Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */
void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */
- int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */
+ int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */
void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */
int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */
int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */
void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */
int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */
- struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */
void (*reserved134)(void);
void (*reserved135)(void);
void (*reserved136)(void);
void (*reserved137)(void);
CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
@@ -800,36 +795,36 @@
Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */
void (*reserved154)(void);
void (*reserved155)(void);
void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */
Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */
- void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
- const char * (*tclGetStartupScriptFileName) (void); /* 159 */
+ TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
+ TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */
void (*reserved160)(void);
int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */
const void * (*tclGetInstructionTable) (void); /* 163 */
void (*tclExpandCodeArray) (void *envPtr); /* 164 */
void (*tclpSetInitialEncodings) (void); /* 165 */
int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */
- void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */
- Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */
+ TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */
+ TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */
int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */
int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */
int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */
int (*tclInThreadExit) (void); /* 172 */
int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */
void (*reserved174)(void);
int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */
void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */
void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */
- void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
- Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */
+ void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
+ Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */
void (*reserved180)(void);
void (*reserved181)(void);
- struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
- struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
void (*reserved184)(void);
void (*reserved185)(void);
void (*reserved186)(void);
void (*reserved187)(void);
void (*reserved188)(void);
@@ -878,11 +873,11 @@
int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */
int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
- void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
+ TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */
int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */
@@ -1086,42 +1081,42 @@
(tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */
#define TclSockMinimumBuffers \
(tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */
#define Tcl_AddInterpResolvers \
(tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */
-#define Tcl_AppendExportList \
- (tclIntStubsPtr->tcl_AppendExportList) /* 112 */
-#define Tcl_CreateNamespace \
- (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */
-#define Tcl_DeleteNamespace \
- (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */
-#define Tcl_Export \
- (tclIntStubsPtr->tcl_Export) /* 115 */
-#define Tcl_FindCommand \
- (tclIntStubsPtr->tcl_FindCommand) /* 116 */
-#define Tcl_FindNamespace \
- (tclIntStubsPtr->tcl_FindNamespace) /* 117 */
+#define TclAppendExportList \
+ (tclIntStubsPtr->tclAppendExportList) /* 112 */
+#define TclCreateNamespace \
+ (tclIntStubsPtr->tclCreateNamespace) /* 113 */
+#define TclDeleteNamespace \
+ (tclIntStubsPtr->tclDeleteNamespace) /* 114 */
+#define TclExport \
+ (tclIntStubsPtr->tclExport) /* 115 */
+#define TclFindCommand \
+ (tclIntStubsPtr->tclFindCommand) /* 116 */
+#define TclFindNamespace \
+ (tclIntStubsPtr->tclFindNamespace) /* 117 */
#define Tcl_GetInterpResolvers \
(tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */
#define Tcl_GetNamespaceResolvers \
(tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */
#define Tcl_FindNamespaceVar \
(tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */
-#define Tcl_ForgetImport \
- (tclIntStubsPtr->tcl_ForgetImport) /* 121 */
-#define Tcl_GetCommandFromObj \
- (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */
-#define Tcl_GetCommandFullName \
- (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */
-#define Tcl_GetCurrentNamespace \
- (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */
-#define Tcl_GetGlobalNamespace \
- (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */
+#define TclForgetImport \
+ (tclIntStubsPtr->tclForgetImport) /* 121 */
+#define TclGetCommandFromObj \
+ (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */
+#define TclGetCommandFullName \
+ (tclIntStubsPtr->tclGetCommandFullName) /* 123 */
+#define TclGetCurrentNamespace_ \
+ (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */
+#define TclGetGlobalNamespace_ \
+ (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */
#define Tcl_GetVariableFullName \
(tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */
-#define Tcl_Import \
- (tclIntStubsPtr->tcl_Import) /* 127 */
+#define TclImport \
+ (tclIntStubsPtr->tclImport) /* 127 */
#define Tcl_PopCallFrame \
(tclIntStubsPtr->tcl_PopCallFrame) /* 128 */
#define Tcl_PushCallFrame \
(tclIntStubsPtr->tcl_PushCallFrame) /* 129 */
#define Tcl_RemoveInterpResolvers \
@@ -1208,14 +1203,14 @@
(tclIntStubsPtr->tclCallVarTraces) /* 175 */
#define TclCleanupVar \
(tclIntStubsPtr->tclCleanupVar) /* 176 */
#define TclVarErrMsg \
(tclIntStubsPtr->tclVarErrMsg) /* 177 */
-#define Tcl_SetStartupScript \
- (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */
-#define Tcl_GetStartupScript \
- (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */
+#define TclSetStartupScript \
+ (tclIntStubsPtr->tclSetStartupScript) /* 178 */
+#define TclGetStartupScript \
+ (tclIntStubsPtr->tclGetStartupScript) /* 179 */
/* Slot 180 is reserved */
/* Slot 181 is reserved */
#define TclpLocaltime \
(tclIntStubsPtr->tclpLocaltime) /* 182 */
#define TclpGmtime \
@@ -1348,60 +1343,30 @@
/* !END!: Do not edit above this line. */
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
-#undef TclGetStartupScriptFileName
-#undef TclSetStartupScriptFileName
-#undef TclGetStartupScriptPath
-#undef TclSetStartupScriptPath
-#undef TclBackgroundException
-
-#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED)
-# undef Tcl_SetStartupScript
-# define Tcl_SetStartupScript \
- (tclStubsPtr->tcl_SetStartupScript) /* 622 */
-# undef Tcl_GetStartupScript
-# define Tcl_GetStartupScript \
- (tclStubsPtr->tcl_GetStartupScript) /* 623 */
-# undef Tcl_CreateNamespace
-# define Tcl_CreateNamespace \
- (tclStubsPtr->tcl_CreateNamespace) /* 506 */
-# undef Tcl_DeleteNamespace
-# define Tcl_DeleteNamespace \
- (tclStubsPtr->tcl_DeleteNamespace) /* 507 */
-# undef Tcl_AppendExportList
-# define Tcl_AppendExportList \
- (tclStubsPtr->tcl_AppendExportList) /* 508 */
-# undef Tcl_Export
-# define Tcl_Export \
- (tclStubsPtr->tcl_Export) /* 509 */
-# undef Tcl_Import
-# define Tcl_Import \
- (tclStubsPtr->tcl_Import) /* 510 */
-# undef Tcl_ForgetImport
-# define Tcl_ForgetImport \
- (tclStubsPtr->tcl_ForgetImport) /* 511 */
-# undef Tcl_GetCurrentNamespace
-# define Tcl_GetCurrentNamespace \
- (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */
-# undef Tcl_GetGlobalNamespace
-# define Tcl_GetGlobalNamespace \
- (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */
-# undef Tcl_FindNamespace
-# define Tcl_FindNamespace \
- (tclStubsPtr->tcl_FindNamespace) /* 514 */
-# undef Tcl_FindCommand
-# define Tcl_FindCommand \
- (tclStubsPtr->tcl_FindCommand) /* 515 */
-# undef Tcl_GetCommandFromObj
-# define Tcl_GetCommandFromObj \
- (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */
-# undef Tcl_GetCommandFullName
-# define Tcl_GetCommandFullName \
- (tclStubsPtr->tcl_GetCommandFullName) /* 517 */
+#if defined(USE_TCL_STUBS)
+# undef TclGetStartupScriptFileName
+# undef TclSetStartupScriptFileName
+# undef TclGetStartupScriptPath
+# undef TclSetStartupScriptPath
+# undef TclBackgroundException
+# undef TclSetStartupScript
+# undef TclGetStartupScript
+# undef TclCreateNamespace
+# undef TclDeleteNamespace
+# undef TclAppendExportList
+# undef TclExport
+# undef TclImport
+# undef TclForgetImport
+# undef TclGetCurrentNamespace_
+# undef TclGetGlobalNamespace_
+# undef TclFindNamespace
+# undef TclFindCommand
+# undef TclGetCommandFromObj
+# undef TclGetCommandFullName
+# undef TclCopyChannelOld
+# undef TclSockMinimumBuffersOld
#endif
-#undef TclCopyChannelOld
-#undef TclSockMinimumBuffersOld
-
#endif /* _TCLINTDECLS */
Index: generic/tclListObj.c
==================================================================
--- generic/tclListObj.c
+++ generic/tclListObj.c
@@ -1955,12 +1955,12 @@
static void
UpdateStringOfList(
Tcl_Obj *listPtr) /* List object with string rep to update. */
{
-# define LOCAL_SIZE 20
- int localFlags[LOCAL_SIZE], *flagPtr = NULL;
+# define LOCAL_SIZE 64
+ char localFlags[LOCAL_SIZE], *flagPtr = NULL;
List *listRepPtr = ListRepPtr(listPtr);
int numElems = listRepPtr->elemCount;
int i, length, bytesNeeded = 0;
const char *elem;
char *dst;
@@ -1993,11 +1993,11 @@
} else {
/*
* We know numElems <= LIST_MAX, so this is safe.
*/
- flagPtr = ckalloc(numElems * sizeof(int));
+ flagPtr = ckalloc(numElems);
}
elemPtrs = &listRepPtr->elements;
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
Index: generic/tclMain.c
==================================================================
--- generic/tclMain.c
+++ generic/tclMain.c
@@ -264,22 +264,18 @@
* Test for the existence of the rc file before trying to read it.
*/
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
if (c != NULL) {
- Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1);
-
Tcl_Close(NULL, c);
- Tcl_IncrRefCount(fullNameObj);
- if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) {
+ if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
- Tcl_DecrRefCount(fullNameObj);
}
}
Tcl_DStringFree(&temp);
}
}
Index: generic/tclNamesp.c
==================================================================
--- generic/tclNamesp.c
+++ generic/tclNamesp.c
@@ -2422,10 +2422,39 @@
}
/*
*----------------------------------------------------------------------
*
+ * TclEnsureNamespace --
+ *
+ * Provide a namespace that is not deleted.
+ *
+ * Value
+ *
+ * namespacePtr, if it is not scheduled for deletion, or a pointer to a
+ * new namespace with the same name otherwise.
+ *
+ * Effect
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Namespace *
+TclEnsureNamespace(
+ Tcl_Interp *interp,
+ Tcl_Namespace *namespacePtr)
+{
+ Namespace *nsPtr = (Namespace *) namespacePtr;
+ if (!(nsPtr->flags & NS_DYING)) {
+ return namespacePtr;
+ }
+ return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_FindNamespace --
*
* Searches for a namespace.
*
* Results:
@@ -2636,11 +2665,11 @@
}
} else {
Namespace *nsPtr[2];
register int search;
- TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
+ TclGetNamespaceForQualName(interp, name, cxtNsPtr,
flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the command in the command table of its namespace. Be sure
* to check both possible search paths: from the specified namespace
Index: generic/tclOO.c
==================================================================
--- generic/tclOO.c
+++ generic/tclOO.c
@@ -536,11 +536,12 @@
* ----------------------------------------------------------------------
*
* AllocObject --
*
* Allocate an object of basic type. Does not splice the object into its
- * class's instance list.
+ * class's instance list. The caller must set the classPtr on the object,
+ * either to a class or to NULL.
*
* ----------------------------------------------------------------------
*/
static Object *
@@ -559,11 +560,14 @@
{
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
+ Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
+ Tcl_Namespace *inNsPtr;
int creationEpoch, ignored;
+ const char *simpleName;
oPtr = ckalloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
/*
@@ -649,28 +653,22 @@
* Finally, create the object commands and initialize the trace on the
* public command (so that the object structures are deleted when the
* command is deleted).
*/
- if (!nameStr) {
- oPtr->command = Tcl_CreateObjCommand(interp,
- oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL);
- } else if (nameStr[0] == ':' && nameStr[1] == ':') {
- oPtr->command = Tcl_CreateObjCommand(interp, nameStr,
- PublicObjectCmd, oPtr, NULL);
+ if (nameStr) {
+ inNsPtr = TclGetCurrentNamespace(interp);
} else {
- Tcl_DString buffer;
-
- Tcl_DStringInit(&buffer);
- Tcl_DStringAppend(&buffer,
- Tcl_GetCurrentNamespace(interp)->fullName, -1);
- TclDStringAppendLiteral(&buffer, "::");
- Tcl_DStringAppend(&buffer, nameStr, -1);
- oPtr->command = Tcl_CreateObjCommand(interp,
- Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL);
- Tcl_DStringFree(&buffer);
- }
+ nameStr = oPtr->namespacePtr->name;
+ inNsPtr = oPtr->namespacePtr;
+ }
+
+ TclGetNamespaceForQualName(interp, nameStr, (Namespace *) inNsPtr, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
+
+ oPtr->command = TclCreateObjCommandInNs(interp, simpleName,
+ (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
/*
* Add the NRE command and trace directly. While this breaks a number of
* abstractions, it is faster and we're inside Tcl here so we're allowed.
*/
@@ -1699,10 +1697,12 @@
*/
AllocClass(interp, oPtr);
oPtr->selfCls = classPtr;
TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
+ } else {
+ oPtr->classPtr = NULL;
}
/*
* Run constructors, except when objc < 0 (a special flag case used for
* object cloning only).
@@ -1789,10 +1789,15 @@
Foundation *fPtr = GetFoundation(interp);
CallContext *contextPtr;
Tcl_InterpState state;
Object *oPtr;
+ /*
+ * Protect classPtr from getting cleaned up when the command is created.
+ */
+ AddRef(classPtr);
+
/*
* Check if we're going to create an object over an existing command;
* that's not allowed.
*/
@@ -1836,15 +1841,17 @@
* object cloning only). If there aren't any constructors, we do nothing.
*/
if (objc < 0) {
*objectPtr = (Tcl_Object) oPtr;
+ DelRef(classPtr);
return TCL_OK;
}
contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
if (contextPtr == NULL) {
*objectPtr = (Tcl_Object) oPtr;
+ DelRef(classPtr);
return TCL_OK;
}
state = Tcl_SaveInterpState(interp, TCL_OK);
contextPtr->callPtr->flags |= CONSTRUCTOR;
@@ -1864,10 +1871,11 @@
AddRef(oPtr);
TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
objectPtr);
TclPushTailcallPoint(interp);
+ DelRef(classPtr);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
static int
FinalizeAlloc(
Index: generic/tclObj.c
==================================================================
--- generic/tclObj.c
+++ generic/tclObj.c
@@ -217,10 +217,13 @@
static void FreeBignum(Tcl_Obj *objPtr);
static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void UpdateStringOfBignum(Tcl_Obj *objPtr);
static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int copy, mp_int *bignumValue);
+static void FreeComplex(Tcl_Obj *objPtr);
+static void DupComplex(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
+static void UpdateStringOfComplex(Tcl_Obj *objPtr);
/*
* Prototypes for the array hash key methods.
*/
@@ -283,10 +286,17 @@
"bignum", /* name */
FreeBignum, /* freeIntRepProc */
DupBignum, /* dupIntRepProc */
UpdateStringOfBignum, /* updateStringProc */
NULL /* setFromAnyProc */
+};
+const Tcl_ObjType tclComplexType = {
+ "complex", /* name */
+ FreeComplex, /* freeIntRepProc */
+ DupComplex, /* dupIntRepProc */
+ UpdateStringOfComplex, /* updateStringProc */
+ NULL /* setFromAnyProc */
};
/*
* The structure below defines the Tcl obj hash key type.
*/
@@ -2290,10 +2300,17 @@
}
return TCL_ERROR;
}
*dblPtr = (double) objPtr->internalRep.doubleValue;
return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclComplexType) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "value is complex", -1));
+ }
+ return TCL_ERROR;
}
if (objPtr->typePtr == &tclIntType) {
*dblPtr = objPtr->internalRep.longValue;
return TCL_OK;
}
@@ -3197,11 +3214,11 @@
*
* Results:
* None.
*
* Side effects:
- * The destination object receies a copy of the source object
+ * The destination object receives a copy of the source object
*
*----------------------------------------------------------------------
*/
static void
@@ -3410,11 +3427,12 @@
TclInitBignumFromWideInt(bignumValue,
objPtr->internalRep.wideValue);
return TCL_OK;
}
#endif
- if (objPtr->typePtr == &tclDoubleType) {
+ if (objPtr->typePtr == &tclDoubleType ||
+ objPtr->typePtr == &tclComplexType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
@@ -3615,10 +3633,175 @@
}
/*
*----------------------------------------------------------------------
*
+ * FreeComplex --
+ *
+ * This function frees the internal rep of a complex.
+ *
+ * Results:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeComplex(
+ Tcl_Obj *objPtr)
+{
+ ckfree((char *) objPtr->internalRep.otherValuePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupComplex --
+ *
+ * This function duplicates the internal rep of a complex.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The destination object receives a copy of the source object
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupComplex(
+ Tcl_Obj *srcPtr,
+ Tcl_Obj *dupPtr)
+{
+ double *srcComplex = srcPtr->internalRep.otherValuePtr;
+ double *dupComplex = (double *) ckalloc(sizeof(double) * 2);
+
+ memcpy(dupComplex, srcComplex, sizeof(double) * 2);
+ dupPtr->internalRep.otherValuePtr = dupComplex;
+ dupPtr->typePtr = &tclComplexType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfComplex --
+ *
+ * This function updates the string representation of a complex object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's string is set to whatever results from the complex-
+ * to-string conversion.
+ *
+ * The object's existing string representation is NOT freed; memory will leak
+ * if the string rep is still valid at the time this function is called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfComplex(
+ Tcl_Obj *objPtr)
+{
+ char buffer[TCL_DOUBLE_SPACE*2+3];
+ double *complex = (double *) objPtr->internalRep.otherValuePtr;
+ register int len = 0;
+
+ if (complex[0] != 0.0) {
+ Tcl_PrintDouble(NULL, complex[0], buffer);
+ len = strlen(buffer);
+ buffer[len] = '_';
+ len++;
+ }
+ Tcl_PrintDouble(NULL, complex[1], &buffer[len]);
+ len = strlen(buffer);
+ buffer[len] = 'i';
+ len++;
+ buffer[len] = 0;
+
+ objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
+ strcpy(objPtr->bytes, buffer);
+ objPtr->length = len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetComplexFromObj --
+ *
+ * Attempt to return a complex from the Tcl object "objPtr". If the object
+ * is not already a complex, an attempt will be made to convert it to one.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already a complex, the conversion may free any
+ * old internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetComplexFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr, /* The object from which to get a double. */
+ register double *realPtr, /* Place to store resulting real double. */
+ register double *imagPtr) /* Place to store resulting imaginary double. */
+{
+ do {
+ if (objPtr->typePtr == &tclComplexType) {
+ double *complex = (double *) objPtr->internalRep.otherValuePtr;
+ *realPtr = complex[0];
+ *imagPtr = complex[1];
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (TclIsNaN(objPtr->internalRep.doubleValue)) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "floating point value is Not a Number", -1));
+ }
+ return TCL_ERROR;
+ }
+ *realPtr = (double) objPtr->internalRep.doubleValue;
+ *imagPtr = 0.0;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclIntType) {
+ *realPtr = objPtr->internalRep.longValue;
+ *imagPtr = 0.0;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ mp_int big;
+
+ UNPACK_BIGNUM(objPtr, big);
+ *realPtr = TclBignumToDouble(&big);
+ *imagPtr = 0.0;
+ return TCL_OK;
+ }
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (objPtr->typePtr == &tclWideIntType) {
+ *realPtr = (double) objPtr->internalRep.wideValue;
+ *imagPtr = 0.0;
+ return TCL_OK;
+ }
+#endif
+ } while (TclParseNumber(interp, objPtr, "floating-point number", NULL, -1,
+ NULL, 0) == TCL_OK);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclGetNumberFromObj --
*
* Extracts a number (of any possible numeric type) from an object.
*
* Results:
@@ -3648,10 +3831,15 @@
} else {
*typePtr = TCL_NUMBER_DOUBLE;
}
*clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclComplexType) {
+ *typePtr = TCL_NUMBER_COMPLEX;
+ *clientDataPtr = &(objPtr->internalRep.otherValuePtr);
+ return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_LONG;
*clientDataPtr = &objPtr->internalRep.longValue;
return TCL_OK;
Index: generic/tclPkg.c
==================================================================
--- generic/tclPkg.c
+++ generic/tclPkg.c
@@ -416,11 +416,11 @@
void *clientDataPtr)
{
Interp *iPtr = (Interp *) interp;
Package *pkgPtr;
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
- char *availVersion, *bestVersion;
+ char *availVersion, *bestVersion, *bestStableVersion;
/* Internal rep. of versions */
int availStable, code, satisfies, pass;
char *script, *pkgVersionI;
Tcl_DString command;
@@ -464,10 +464,11 @@
*/
bestPtr = NULL;
bestStablePtr = NULL;
bestVersion = NULL;
+ bestStableVersion = NULL;
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert(interp, availPtr->version,
&availVersion, &availStable) != TCL_OK) {
@@ -478,63 +479,85 @@
*/
continue;
}
- if (bestPtr != NULL) {
- int res = CompareVersions(availVersion, bestVersion, NULL);
-
- /*
- * Note: Use internal reps!
- */
-
- if (res <= 0) {
- /*
- * The version of the package sought is not as good as the
- * currently selected version. Ignore it.
- */
-
- ckfree(availVersion);
- availVersion = NULL;
- continue;
- }
- }
-
- /*
- * We have found a version which is better than our max.
- */
-
+ /* Check satisfaction of requirements before considering the current version further. */
if (reqc > 0) {
- /* Check satisfaction of requirements. */
-
satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
if (!satisfies) {
ckfree(availVersion);
availVersion = NULL;
continue;
}
}
- bestPtr = availPtr;
-
- if (bestVersion != NULL) {
- ckfree(bestVersion);
- }
- bestVersion = availVersion;
-
- /*
- * If this new best version is stable then it also has to be
- * better than the max stable version found so far.
- */
-
- if (availStable) {
+ if (bestPtr != NULL) {
+ int res = CompareVersions(availVersion, bestVersion, NULL);
+
+ /*
+ * Note: Used internal reps in the comparison!
+ */
+
+ if (res > 0) {
+ /*
+ * The version of the package sought is better than the
+ * currently selected version.
+ */
+ goto newbest;
+ }
+ } else {
+ newbest:
+ /* We have found a version which is better than our max. */
+
+ bestPtr = availPtr;
+ CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
+ }
+
+ if (!availStable) {
+ ckfree(availVersion);
+ availVersion = NULL;
+ continue;
+ }
+
+ if (bestStablePtr != NULL) {
+ int res = CompareVersions(availVersion, bestStableVersion, NULL);
+
+ /*
+ * Note: Used internal reps in the comparison!
+ */
+
+ if (res > 0) {
+ /*
+ * This stable version of the package sought is better
+ * than the currently selected stable version.
+ */
+ goto newstable;
+ }
+ } else {
+ newstable:
+ /* We have found a stable version which is better than our max stable. */
bestStablePtr = availPtr;
+ CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL);
}
- }
+
+ ckfree(availVersion);
+ availVersion = NULL;
+ } /* end for */
+
+ /*
+ * Clean up memorized internal reps, if any.
+ */
if (bestVersion != NULL) {
ckfree(bestVersion);
+ bestVersion = NULL;
+ }
+
+ if (bestStableVersion != NULL) {
+ ckfree(bestStableVersion);
+ bestStableVersion = NULL;
}
/*
* Now choose a version among the two best. For 'latest' we simply
* take (actually keep) the best. For 'stable' we take the best
Index: generic/tclProc.c
==================================================================
--- generic/tclProc.c
+++ generic/tclProc.c
@@ -122,15 +122,14 @@
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
- const char *fullName;
- const char *procName, *procArgs, *procBody;
+ const char *procName;
+ const char *simpleName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
- Tcl_DString ds;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "name args body");
return TCL_ERROR;
}
@@ -139,66 +138,43 @@
* Determine the namespace where the procedure should reside. Unless the
* command name includes namespace qualifiers, this will be the current
* namespace.
*/
- fullName = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, fullName, NULL, 0,
- &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+ procName = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, procName, NULL, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
- fullName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
- if (procName == NULL) {
+ if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
- fullName));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
- return TCL_ERROR;
- }
- if ((nsPtr != iPtr->globalNsPtr)
- && (procName != NULL) && (procName[0] == ':')) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create procedure \"%s\" in non-global namespace with"
- " name starting with \":\"", procName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
/*
* Create the data structure to represent the procedure.
*/
- if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
+ if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3],
&procPtr) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (creating proc \"");
- Tcl_AddErrorInfo(interp, procName);
+ Tcl_AddErrorInfo(interp, simpleName);
Tcl_AddErrorInfo(interp, "\")");
return TCL_ERROR;
}
- /*
- * Now create a command for the procedure. This will initially be in the
- * current namespace unless the procedure's name included namespace
- * qualifiers. To create the new command in the right namespace, we
- * generate a fully qualified name for it.
- */
-
- Tcl_DStringInit(&ds);
- if (nsPtr != iPtr->globalNsPtr) {
- Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
- TclDStringAppendLiteral(&ds, "::");
- }
- Tcl_DStringAppend(&ds, procName, -1);
-
- cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc,
- TclNRInterpProc, procPtr, TclProcDeleteProc);
- Tcl_DStringFree(&ds);
+ cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
+ TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc);
/*
* Now initialize the new procedure's cmdPtr field. This will be used
* later when the procedure is called to determine what namespace the
* procedure will run in. This will be different than the current
@@ -391,17 +367,17 @@
Tcl_Obj *argsPtr, /* Description of arguments. */
Tcl_Obj *bodyPtr, /* Command body. */
Proc **procPtrPtr) /* Returns: pointer to proc data. */
{
Interp *iPtr = (Interp *) interp;
- const char **argArray = NULL;
register Proc *procPtr;
- int i, length, result, numArgs;
- const char *args, *bytes, *p;
+ int i, result, numArgs, plen;
+ const char *bytes, *argname, *argnamei;
+ char argnamelast;
register CompiledLocal *localPtr = NULL;
- Tcl_Obj *defPtr;
+ Tcl_Obj *defPtr, *errorObj, **argArray;
int precompiled = 0;
if (bodyPtr->typePtr == &tclProcBodyType) {
/*
* Because the body is a TclProProcBody, the actual body is already
@@ -434,10 +410,11 @@
* identical. Note that we don't use Tcl_DuplicateObj since we would
* not want any bytecode internal representation.
*/
if (Tcl_IsShared(bodyPtr)) {
+ int length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = TclGetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
@@ -471,16 +448,13 @@
/*
* Break up the argument list into argument specifiers, then process each
* argument specifier. If the body is precompiled, processing is limited
* to checking that the parsed argument is consistent with the one stored
* in the Proc.
- *
- * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS.
*/
- args = TclGetStringFromObj(argsPtr, &length);
- result = Tcl_SplitList(interp, args, &numArgs, &argArray);
+ result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray);
if (result != TCL_OK) {
goto procError;
}
if (precompiled) {
@@ -500,77 +474,74 @@
}
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength;
size_t valueLength;
- const char **fieldValues;
+ Tcl_Obj **fieldValues;
/*
* Now divide the specifier up into name and default.
*/
- result = Tcl_SplitList(interp, argArray[i], &fieldCount,
+ result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
}
if (fieldCount > 2) {
- ckfree(fieldValues);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "too many fields in argument specifier \"%s\"",
- argArray[i]));
+ errorObj = Tcl_NewStringObj(
+ "too many fields in argument specifier \"", -1);
+ Tcl_AppendObjToObj(errorObj, argArray[i]);
+ Tcl_AppendToObj(errorObj, "\"", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
- ckfree(fieldValues);
+ if ((fieldCount == 0) || (fieldValues[0]->length == 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- nameLength = strlen(fieldValues[0]);
+ nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length);
if (fieldCount == 2) {
- valueLength = strlen(fieldValues[1]);
+ valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]),
+ fieldValues[1]->length);
} else {
valueLength = 0;
}
/*
* Check that the formal parameter name is a scalar.
*/
- p = fieldValues[0];
- while (*p != '\0') {
- if (*p == '(') {
- const char *q = p;
- do {
- q++;
- } while (*q != '\0');
- q--;
- if (*q == ')') { /* We have an array element. */
+ argname = Tcl_GetStringFromObj(fieldValues[0], &plen);
+ argnamei = argname;
+ argnamelast = argname[plen-1];
+ while (plen--) {
+ if (argnamei[0] == '(') {
+ if (argnamelast == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
- fieldValues[0]));
- ckfree(fieldValues);
+ Tcl_GetString(fieldValues[0])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- } else if ((*p == ':') && (*(p+1) == ':')) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "formal parameter \"%s\" is not a simple name",
- fieldValues[0]));
- ckfree(fieldValues);
+ } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) {
+ errorObj = Tcl_NewStringObj("formal parameter \"", -1);
+ Tcl_AppendObjToObj(errorObj, fieldValues[0]);
+ Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- p++;
+ argnamei = Tcl_UtfNext(argnamei);
}
if (precompiled) {
/*
* Compare the parsed argument with the stored one. Note that the
@@ -582,19 +553,18 @@
* precompiled procs is VAR_TEMPORARY (also unchanged). It is
* needed later when retrieving the variable names.
*/
if ((localPtr->nameLength != nameLength)
- || (strcmp(localPtr->name, fieldValues[0]))
+ || (Tcl_UtfNcmp(localPtr->name, argname, nameLength))
|| (localPtr->frameIndex != i)
|| !(localPtr->flags & VAR_ARGUMENT)
|| (localPtr->defValuePtr == NULL && fieldCount == 2)
|| (localPtr->defValuePtr != NULL && fieldCount != 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\": formal parameter %d is "
"inconsistent with precompiled body", procName, i));
- ckfree(fieldValues);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", NULL);
goto procError;
}
@@ -605,16 +575,17 @@
if (localPtr->defValuePtr != NULL) {
const char *tmpPtr = TclGetString(localPtr->defValuePtr);
size_t tmpLength = localPtr->defValuePtr->length;
if ((valueLength != tmpLength) ||
- strncmp(fieldValues[1], tmpPtr, tmpLength)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "procedure \"%s\": formal parameter \"%s\" has "
- "default value inconsistent with precompiled body",
- procName, fieldValues[0]));
- ckfree(fieldValues);
+ Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) {
+ errorObj = Tcl_ObjPrintf(
+ "procedure \"%s\": formal parameter \"" ,procName);
+ Tcl_AppendObjToObj(errorObj, fieldValues[0]);
+ Tcl_AppendToObj(errorObj, "\" has "
+ "default value inconsistent with precompiled body", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", NULL);
goto procError;
}
}
@@ -630,44 +601,40 @@
/*
* Allocate an entry in the runtime procedure frame's array of
* local variables for the argument.
*/
- localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1);
+ localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
- localPtr->nameLength = nameLength;
+ localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length);
localPtr->frameIndex = i;
localPtr->flags = VAR_ARGUMENT;
localPtr->resolveInfo = NULL;
if (fieldCount == 2) {
- localPtr->defValuePtr =
- Tcl_NewStringObj(fieldValues[1], valueLength);
+ localPtr->defValuePtr = fieldValues[1];
Tcl_IncrRefCount(localPtr->defValuePtr);
} else {
localPtr->defValuePtr = NULL;
}
- memcpy(localPtr->name, fieldValues[0], nameLength + 1);
+ memcpy(localPtr->name, argname, fieldValues[0]->length + 1);
if ((i == numArgs - 1)
&& (localPtr->nameLength == 4)
&& (localPtr->name[0] == 'a')
&& (strcmp(localPtr->name, "args") == 0)) {
localPtr->flags |= VAR_IS_ARGS;
}
}
-
- ckfree(fieldValues);
}
*procPtrPtr = procPtr;
- ckfree(argArray);
return TCL_OK;
procError:
if (precompiled) {
procPtr->refCount--;
@@ -684,13 +651,10 @@
ckfree(localPtr);
}
ckfree(procPtr);
}
- if (argArray != NULL) {
- ckfree(argArray);
- }
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
Index: generic/tclScan.c
==================================================================
--- generic/tclScan.c
+++ generic/tclScan.c
@@ -883,13 +883,21 @@
case 'c':
/*
* Scan a single Unicode character.
*/
- string += TclUtfToUniChar(string, &sch);
+ offset = TclUtfToUniChar(string, &sch);
+ i = (int)sch;
+#if TCL_UTF_MAX == 4
+ if (!offset) {
+ offset = Tcl_UtfToUniChar(string, &sch);
+ i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF);
+ }
+#endif
+ string += offset;
if (!(flags & SCAN_SUPPRESS)) {
- objPtr = Tcl_NewIntObj((int)sch);
+ objPtr = Tcl_NewIntObj(i);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
break;
Index: generic/tclStrToD.c
==================================================================
--- generic/tclStrToD.c
+++ generic/tclStrToD.c
@@ -484,10 +484,11 @@
INITIAL, SIGNUM, ZERO, ZERO_X,
ZERO_O, ZERO_B, ZERO_D, BINARY,
HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL,
LEADING_RADIX_POINT, FRACTION,
EXPONENT_START, EXPONENT_SIGNUM, EXPONENT,
+ IMAGINARY, COMPLEX,
sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY
#ifdef IEEE_FLOATING_POINT
, sN, sNA, sNAN, sNANPAREN, sNANHEX, sNANFINISH
#endif
} state = INITIAL;
@@ -516,10 +517,12 @@
int numDigitsAfterDp = 0; /* Number of digits scanned after the decimal
* point. */
int exponentSignum = 0; /* Signum of the exponent of a floating point
* number. */
long exponent = 0; /* Exponent of a floating point number. */
+ double doubleValue; /* Store double value. */
+ double imagValue = 0.0; /* Store imaginary value. */
const char *p; /* Pointer to next character to scan. */
size_t len; /* Number of characters remaining after p. */
const char *acceptPoint; /* Pointer to position after last character in
* an acceptable number. */
size_t acceptLen; /* Number of characters following that
@@ -923,10 +926,16 @@
break;
} else if (flags & TCL_PARSE_INTEGER_ONLY) {
goto endgame;
} else if (c == '.') {
state = FRACTION;
+ break;
+ } else if (c == '_') {
+ state = COMPLEX;
+ break;
+ } else if (c == 'i') {
+ state = IMAGINARY;
break;
} else if (c == 'E' || c == 'e') {
state = EXPONENT_START;
break;
}
@@ -967,10 +976,16 @@
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
state = FRACTION;
+ break;
+ } else if (c == '_') {
+ state = COMPLEX;
+ break;
+ } else if (c == 'i') {
+ state = IMAGINARY;
break;
}
goto endgame;
case EXPONENT_START:
@@ -1018,13 +1033,31 @@
} else {
exponent = LONG_MAX;
}
state = EXPONENT;
break;
+ } else if (c == '_') {
+ state = COMPLEX;
+ break;
+ } else if (c == 'i') {
+ state = IMAGINARY;
+ break;
}
goto endgame;
+ case IMAGINARY:
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ goto endgame;
+
+ case COMPLEX:
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ goto endgame;
+
/*
* Parse out INFINITY by simply spelling it out. INF is accepted
* as an abbreviation; other prefices are not.
*/
@@ -1141,20 +1174,61 @@
p++;
len--;
}
endgame:
+ if (acceptState == COMPLEX) {
+ /*
+ * Special case for complex, reparse for imaginary part of complex
+ */
+
+ const char *endPtr;
+ int numBytes2 = numBytes < 0 ? -1 : acceptLen;
+ Tcl_Obj *dummy = Tcl_NewObj();
+
+ status = TclParseNumber(interp, dummy, expected, acceptPoint,
+ numBytes2, &endPtr, flags);
+
+ if (status == TCL_OK) {
+ /*
+ * The recursive call must return a complex number with
+ * just an imaginary part.
+ * The internal rep might also be inconsistent after the call
+ * if the parse failed prematurely.
+ */
+
+ if ((numBytes2 < 0 && *endPtr != 0) ||
+ (numBytes2 >= 0 && endPtr < (acceptPoint + numBytes2))) {
+ TclFreeIntRep(objPtr);
+ objPtr->typePtr = NULL;
+ }
+ if (dummy->typePtr != &tclComplexType) {
+ status = TCL_ERROR;
+ } else {
+ double *complexVal = (double *)
+ dummy->internalRep.otherValuePtr;
+ if (complexVal[0] != 0.0) {
+ status = TCL_ERROR;
+ }
+ imagValue = complexVal[1];
+ }
+ acceptPoint = endPtr;
+ acceptLen = len - (endPtr - bytes);
+ }
+ Tcl_DecrRefCount(dummy);
+ }
+
if (acceptState == INITIAL) {
/*
* No numeric string at all found.
*/
status = TCL_ERROR;
if (endPtrPtr != NULL) {
*endPtrPtr = p;
}
- } else {
+ } else if (status == TCL_OK) {
/*
* Back up to the last accepting state in the lexer.
*/
p = acceptPoint;
@@ -1352,32 +1426,49 @@
}
break;
case FRACTION:
case EXPONENT:
+ case IMAGINARY:
+ case COMPLEX:
/*
* Here, we're parsing a floating-point number. 'significandWide'
* or 'significandBig' contains the exact significand, according
* to whether 'significandOverflow' is set. The desired floating
* point value is significand * 10**k, where
* k = numTrailZeros+exponent-numDigitsAfterDp.
*/
- objPtr->typePtr = &tclDoubleType;
if (exponentSignum) {
exponent = -exponent;
}
if (!significandOverflow) {
- objPtr->internalRep.doubleValue = MakeLowPrecisionDouble(
+ doubleValue = MakeLowPrecisionDouble(
signum, significandWide, numSigDigs,
numTrailZeros + exponent - numDigitsAfterDp);
} else {
- objPtr->internalRep.doubleValue = MakeHighPrecisionDouble(
+ doubleValue = MakeHighPrecisionDouble(
signum, &significandBig, numSigDigs,
numTrailZeros + exponent - numDigitsAfterDp);
}
+ if (acceptState == COMPLEX) {
+ double *complexVal = (double *) ckalloc(sizeof(double) * 2);
+ complexVal[0] = doubleValue;
+ complexVal[1] = imagValue;
+ objPtr->internalRep.otherValuePtr = complexVal;
+ objPtr->typePtr = &tclComplexType;
+ } else if (acceptState == IMAGINARY) {
+ double *complexVal = (double *) ckalloc(sizeof(double) * 2);
+ complexVal[0] = 0.0;
+ complexVal[1] = doubleValue;
+ objPtr->internalRep.otherValuePtr = complexVal;
+ objPtr->typePtr = &tclComplexType;
+ } else {
+ objPtr->internalRep.doubleValue = doubleValue;
+ objPtr->typePtr = &tclDoubleType;
+ }
break;
case sINF:
case sINFINITY:
if (signum) {
Index: generic/tclStringObj.c
==================================================================
--- generic/tclStringObj.c
+++ generic/tclStringObj.c
@@ -3240,44 +3240,48 @@
try++;
}
return -1;
}
+ /*
+ * Check if we have two strings of single-byte characters. If we have, we
+ * can use strstr() to do the search. Note that we can sometimes have
+ * multibyte characters when the string could be minimally represented
+ * using single byte characters; we can't assume that a mismatch here
+ * means no match.
+ */
+
lh = Tcl_GetCharLength(haystack);
- if (haystack->bytes && (lh == haystack->length)) {
- /* haystack is all single-byte chars */
-
- if (needle->bytes && (ln == needle->length)) {
- /* needle is also all single-byte chars */
- char *found = strstr(haystack->bytes + start, needle->bytes);
-
- if (found) {
- return (found - haystack->bytes);
- } else {
- return -1;
- }
- } else {
- /*
- * Cannot find substring with a multi-byte char inside
- * a string with no multi-byte chars.
- */
+ if (haystack->bytes && (lh == haystack->length) && needle->bytes
+ && (ln == needle->length)) {
+ /*
+ * Both haystack and needle are all single-byte chars.
+ */
+
+ char *found = strstr(haystack->bytes + start, needle->bytes);
+
+ if (found) {
+ return (found - haystack->bytes);
+ } else {
return -1;
}
} else {
+ /*
+ * Do the search on the unicode representation for simplicity.
+ */
+
Tcl_UniChar *try, *end, *uh;
Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);
uh = Tcl_GetUnicodeFromObj(haystack, &lh);
end = uh + lh;
- try = uh + start;
- while (try + ln <= end) {
- if ((*try == *un)
- && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
+ for (try = uh + start; try + ln <= end; try++) {
+ if ((*try == *un) && (0 ==
+ memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
return (try - uh);
}
- try++;
}
return -1;
}
}
@@ -3456,11 +3460,10 @@
/*
* Create a non-empty, pure unicode value, so we can coax
* Tcl_SetObjLength into growing the unicode rep buffer.
*/
- ch = 0;
objPtr = Tcl_NewUnicodeObj(&ch, 1);
Tcl_SetObjLength(objPtr, stringPtr->numChars);
to = Tcl_GetUnicode(objPtr);
while (--src >= from) {
*to++ = *src;
@@ -3559,11 +3562,11 @@
int numBytes,
int numAppendChars)
{
String *stringPtr = GET_STRING(objPtr);
int needed, numOrigChars = 0;
- Tcl_UniChar *dst;
+ Tcl_UniChar *dst, unichar = 0;
if (stringPtr->hasUnicode) {
numOrigChars = stringPtr->numChars;
}
if (numAppendChars == -1) {
@@ -3582,11 +3585,12 @@
stringPtr->numChars = needed;
} else {
numAppendChars = 0;
}
for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) {
- bytes += TclUtfToUniChar(bytes, dst);
+ bytes += TclUtfToUniChar(bytes, &unichar);
+ *dst = unichar;
}
*dst = 0;
}
/*
Index: generic/tclStubInit.c
==================================================================
--- generic/tclStubInit.c
+++ generic/tclStubInit.c
@@ -364,10 +364,30 @@
# undef Tcl_GlobalEvalObj
# define Tcl_GlobalEvalObj 0
# define TclBackgroundException 0
# undef TclpReaddir
# define TclpReaddir 0
+# define TclSetStartupScript 0
+# define TclGetStartupScript 0
+# define TclCreateNamespace 0
+# define TclDeleteNamespace 0
+# define TclAppendExportList 0
+# define TclExport 0
+# define TclImport 0
+# define TclForgetImport 0
+# define TclGetCurrentNamespace_ 0
+# define TclGetGlobalNamespace_ 0
+# define TclFindNamespace 0
+# define TclFindCommand 0
+# define TclGetCommandFromObj 0
+# define TclGetCommandFullName 0
+# define TclCopyChannelOld 0
+# define Tcl_AppendResultVA 0
+# define Tcl_AppendStringsToObjVA 0
+# define Tcl_SetErrorCodeVA 0
+# define Tcl_PanicVA 0
+# define Tcl_VarEvalVA 0
# undef TclpGetDate
# define TclpGetDate 0
# undef TclpLocaltime
# define TclpLocaltime 0
# undef TclpGmtime
@@ -376,10 +396,24 @@
# define TclpGmtime_unix 0
#else /* TCL_NO_DEPRECATED */
# define Tcl_SeekOld seekOld
# define Tcl_TellOld tellOld
# define TclBackgroundException Tcl_BackgroundException
+# define TclSetStartupScript Tcl_SetStartupScript
+# define TclGetStartupScript Tcl_GetStartupScript
+# define TclCreateNamespace Tcl_CreateNamespace
+# define TclDeleteNamespace Tcl_DeleteNamespace
+# define TclAppendExportList Tcl_AppendExportList
+# define TclExport Tcl_Export
+# define TclImport Tcl_Import
+# define TclForgetImport Tcl_ForgetImport
+# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace
+# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace
+# define TclFindNamespace Tcl_FindNamespace
+# define TclFindCommand Tcl_FindCommand
+# define TclGetCommandFromObj Tcl_GetCommandFromObj
+# define TclGetCommandFullName Tcl_GetCommandFullName
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
static int
seekOld(
@@ -528,26 +562,26 @@
0, /* 107 */
TclTeardownNamespace, /* 108 */
TclUpdateReturnInfo, /* 109 */
TclSockMinimumBuffers, /* 110 */
Tcl_AddInterpResolvers, /* 111 */
- Tcl_AppendExportList, /* 112 */
- Tcl_CreateNamespace, /* 113 */
- Tcl_DeleteNamespace, /* 114 */
- Tcl_Export, /* 115 */
- Tcl_FindCommand, /* 116 */
- Tcl_FindNamespace, /* 117 */
+ TclAppendExportList, /* 112 */
+ TclCreateNamespace, /* 113 */
+ TclDeleteNamespace, /* 114 */
+ TclExport, /* 115 */
+ TclFindCommand, /* 116 */
+ TclFindNamespace, /* 117 */
Tcl_GetInterpResolvers, /* 118 */
Tcl_GetNamespaceResolvers, /* 119 */
Tcl_FindNamespaceVar, /* 120 */
- Tcl_ForgetImport, /* 121 */
- Tcl_GetCommandFromObj, /* 122 */
- Tcl_GetCommandFullName, /* 123 */
- Tcl_GetCurrentNamespace, /* 124 */
- Tcl_GetGlobalNamespace, /* 125 */
+ TclForgetImport, /* 121 */
+ TclGetCommandFromObj, /* 122 */
+ TclGetCommandFullName, /* 123 */
+ TclGetCurrentNamespace_, /* 124 */
+ TclGetGlobalNamespace_, /* 125 */
Tcl_GetVariableFullName, /* 126 */
- Tcl_Import, /* 127 */
+ TclImport, /* 127 */
Tcl_PopCallFrame, /* 128 */
Tcl_PushCallFrame, /* 129 */
Tcl_RemoveInterpResolvers, /* 130 */
Tcl_SetNamespaceResolvers, /* 131 */
TclpHasSockets, /* 132 */
@@ -594,12 +628,12 @@
TclUniCharMatch, /* 173 */
0, /* 174 */
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
- Tcl_SetStartupScript, /* 178 */
- Tcl_GetStartupScript, /* 179 */
+ TclSetStartupScript, /* 178 */
+ TclGetStartupScript, /* 179 */
0, /* 180 */
0, /* 181 */
TclpLocaltime, /* 182 */
TclpGmtime, /* 183 */
0, /* 184 */
Index: generic/tclUtil.c
==================================================================
--- generic/tclUtil.c
+++ generic/tclUtil.c
@@ -972,11 +972,11 @@
const char *src, /* String to convert to Tcl list element. */
int length, /* Number of bytes in src, or -1. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
- int flags = CONVERT_ANY;
+ char flags = CONVERT_ANY;
int numBytes = TclScanElement(src, length, &flags);
*flagPtr = flags;
return numBytes;
}
@@ -1013,11 +1013,11 @@
int
TclScanElement(
const char *src, /* String to convert to Tcl list element. */
int length, /* Number of bytes in src, or -1. */
- int *flagPtr) /* Where to store information to guide
+ char *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
const char *p = src;
int nestingLevel = 0; /* Brace nesting count */
int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something
@@ -1545,15 +1545,14 @@
char *
Tcl_Merge(
int argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
-#define LOCAL_SIZE 20
- int localFlags[LOCAL_SIZE], *flagPtr = NULL;
+#define LOCAL_SIZE 64
+ char localFlags[LOCAL_SIZE], *flagPtr = NULL;
int i, bytesNeeded = 0;
char *result, *dst;
- const int maxFlags = UINT_MAX / sizeof(int);
/*
* Handle empty list case first, so logic of the general case can be
* simpler.
*/
@@ -1568,26 +1567,12 @@
* Pass 1: estimate space, gather flags.
*/
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
- } else if (argc > maxFlags) {
- /*
- * We cannot allocate a large enough flag array to format this list in
- * one pass. We could imagine converting this routine to a multi-pass
- * implementation, but for sizeof(int) == 4, the limit is a max of
- * 2^30 list elements and since each element is at least one byte
- * formatted, and requires one byte space between it and the next one,
- * that a minimum space requirement of 2^31 bytes, which is already
- * INT_MAX. If we tried to format a list of > maxFlags elements, we're
- * just going to overflow the size limits on the formatted string
- * anyway, so just issue that same panic early.
- */
-
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
} else {
- flagPtr = ckalloc(argc * sizeof(int));
+ flagPtr = ckalloc(argc);
}
for (i = 0; i < argc; i++) {
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]);
if (bytesNeeded < 0) {
@@ -2715,11 +2700,11 @@
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
- int flags = needSpace ? TCL_DONT_QUOTE_HASH : 0;
+ char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0;
int newSize = dsPtr->length + needSpace
+ TclScanElement(element, -1, &flags);
/*
* Allocate a larger buffer for the string if the current one isn't large
Index: library/init.tcl
==================================================================
--- library/init.tcl
+++ library/init.tcl
@@ -71,47 +71,10 @@
if {$Dir ni $Path} {
lappend Path $Dir
encoding dirs $Path
}
}
-
- # TIP #255 min and max functions
- namespace eval mathfunc {
- proc min {args} {
- if {![llength $args]} {
- return -code error \
- "too few arguments to math function \"min\""
- }
- set val Inf
- foreach arg $args {
- # This will handle forcing the numeric value without
- # ruining the internal type of a numeric object
- if {[catch {expr {double($arg)}} err]} {
- return -code error $err
- }
- if {$arg < $val} {set val $arg}
- }
- return $val
- }
- proc max {args} {
- if {![llength $args]} {
- return -code error \
- "too few arguments to math function \"max\""
- }
- set val -Inf
- foreach arg $args {
- # This will handle forcing the numeric value without
- # ruining the internal type of a numeric object
- if {[catch {expr {double($arg)}} err]} {
- return -code error $err
- }
- if {$arg > $val} {set val $arg}
- }
- return $val
- }
- namespace export min max
- }
}
namespace eval tcl::Pkg {}
# Windows specific end of initialization
Index: library/opt/optparse.tcl
==================================================================
--- library/opt/optparse.tcl
+++ library/opt/optparse.tcl
@@ -6,14 +6,14 @@
# WARNING: This code will go away in a future release
# of Tcl. It is NOT supported and you should not rely
# on it. If your code does rely on this package you
# may directly incorporate this code into your application.
-package require Tcl 8.2
+package require Tcl 8.5-
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
-package provide opt 0.4.6
+package provide opt 0.4.7
namespace eval ::tcl {
# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
Index: library/opt/pkgIndex.tcl
==================================================================
--- library/opt/pkgIndex.tcl
+++ library/opt/pkgIndex.tcl
@@ -6,7 +6,7 @@
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-if {![package vsatisfies [package provide Tcl] 8.2]} {return}
-package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
+package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]]
Index: library/tcltest/pkgIndex.tcl
==================================================================
--- library/tcltest/pkgIndex.tcl
+++ library/tcltest/pkgIndex.tcl
@@ -6,7 +6,7 @@
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-if {![package vsatisfies [package provide Tcl] 8.5]} {return}
-package ifneeded tcltest 2.4.0 [list source [file join $dir tcltest.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
+package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]]
Index: library/tcltest/tcltest.tcl
==================================================================
--- library/tcltest/tcltest.tcl
+++ library/tcltest/tcltest.tcl
@@ -20,11 +20,11 @@
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
- variable Version 2.4.0
+ variable Version 2.4.1
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
Index: tests/expr-old.test
==================================================================
--- tests/expr-old.test
+++ tests/expr-old.test
@@ -1157,40 +1157,52 @@
} -result 0
test expr-old-40.2 {min math function} -body {
expr {min(0.0)}
} -result 0.0
test expr-old-40.3 {min math function} -body {
- list [catch {expr {min()}} msg] $msg
-} -result {1 {too few arguments to math function "min"}}
+ expr {min()}
+} -returnCodes error -result {too few arguments for math function "min"}
test expr-old-40.4 {min math function} -body {
expr {min(wide(-1) << 30, 4.5, -10)}
} -result [expr {wide(-1) << 30}]
test expr-old-40.5 {min math function} -body {
expr {min("a", 0)}
} -returnCodes error -match glob -result *
test expr-old-40.6 {min math function} -body {
expr {min(300, "0xFF")}
} -result 255
+test expr-old-40.7 {min math function} -body {
+ expr min(1[string repeat 0 10000], 1e300)
+} -result 1e+300
+test expr-old-40.8 {min math function} -body {
+ expr {min(0, "a")}
+} -returnCodes error -match glob -result *
test expr-old-41.1 {max math function} -body {
expr {max(0)}
} -result 0
test expr-old-41.2 {max math function} -body {
expr {max(0.0)}
} -result 0.0
test expr-old-41.3 {max math function} -body {
- list [catch {expr {max()}} msg] $msg
-} -result {1 {too few arguments to math function "max"}}
+ expr {max()}
+} -returnCodes error -result {too few arguments for math function "max"}
test expr-old-41.4 {max math function} -body {
expr {max(wide(1) << 30, 4.5, -10)}
} -result [expr {wide(1) << 30}]
test expr-old-41.5 {max math function} -body {
expr {max("a", 0)}
} -returnCodes error -match glob -result *
test expr-old-41.6 {max math function} -body {
expr {max(200, "0xFF")}
} -result 255
+test expr-old-41.7 {max math function} -body {
+ expr max(1[string repeat 0 10000], 1e300)
+} -result 1[string repeat 0 10000]
+test expr-old-41.8 {max math function} -body {
+ expr {max(0, "a")}
+} -returnCodes error -match glob -result *
# Special test for Pentium arithmetic bug of 1994:
if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {
puts "Warning: this machine contains a defective Pentium processor"
Index: tests/expr.test
==================================================================
--- tests/expr.test
+++ tests/expr.test
@@ -6711,10 +6711,16 @@
::tcl::mathfunc::abs { -0x0}
} 0
test expr-38.13 {abs and 0.0 [Bug 2954959]} {
::tcl::mathfunc::abs 1e-324
} 1e-324
+test expr-38.14 {abs on complex} {
+ expr {abs(3.0+4.0i)}
+} 5.0
+test expr-38.15 {abs on complex} {
+ expr {abs(4.0i)}
+} 4.0
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
testConstraint testexprdoubleobj [llength [info commands testexprdoubleobj]]
test expr-39.1 {Check that Tcl_ExprLongObj doesn't modify interpreter result if no error} testexprlongobj {
@@ -7185,10 +7191,130 @@
test expr-51.1 {test round-to-even on input} {
expr 6.9294956446009195e15
} 6929495644600920.0
+test expr-52.1 {complex numbers} -body {
+ expr {1.0+1.0i+2.0+3.5i}
+} -result 3.0_4.5i
+
+test expr-52.2 {complex numbers} -body {
+ expr {(1.0+1.0i)*(2.0+3.5i)}
+} -result -1.5_5.5i
+
+test expr-52.3 {complex numbers} -body {
+ expr {1.0+1.0i*2.0+3.5i}
+} -result 1.0_5.5i
+
+test expr-52.4 {complex numbers} -body {
+ set a [expr {1.0+2.0i}]
+ set b [expr {5.0+3.0i}]
+ # Test that literal works unbraced and braced
+ list $a $b [expr $a * $b] [expr {$a * $b}]
+} -result "1.0_2.0i 5.0_3.0i -1.0_13.0i -1.0_13.0i"
+
+test expr-52.5 {complex numbers} -body {
+ set a [expr {1.0+2.0i}]
+ # Test that negation works unbraced and braced
+ list $a [expr -$a] [expr {-$a}]
+} -result "1.0_2.0i -1.0_-2.0i -1.0_-2.0i"
+
+test expr-52.6 {complex numbers} -constraints knownBug -body {
+ set b [expr {-5.0+3.0i}]
+ # Test that negative literal works unbraced and braced
+ list $b [expr $b] [expr {$b}]
+} -result "-5.0_3.0i -5.0_3.0i -5.0_3.0i"
+
+test expr-52.7 {complex numbers} -constraints knownBug -body {
+ set b [expr {-5.0+3.0i}]
+ # Test that negation works unbraced and braced
+ list $b [expr -$b] [expr {-$b}]
+} -result "-5.0_3.0i 5.0_-3.0i 5.0_-3.0i"
+
+test expr-52.8 {complex numbers} -body {
+ # Test all code paths through comparisons with complex numbers
+ set res {}
+ lappend res [expr {1.0+1.5i < 0.5+2.0i}]
+ lappend res [expr {0.5+2.0i > 1.0+1.5i}]
+ # Int
+ lappend res [expr {1 < 2i}]
+ lappend res [expr {1i < 2}]
+ lappend res [expr {2 > 1i}]
+ lappend res [expr {2i > 1}]
+ # Wide
+ lappend res [expr {10000000001 < 10000000002i}]
+ lappend res [expr {10000000001i < 10000000002}]
+ lappend res [expr {10000000002 > 10000000001i}]
+ lappend res [expr {10000000002i > 10000000001}]
+ # Bignum
+ lappend res [expr {1000000000000000000000000000 < 1000000000000001000000000000i}]
+ lappend res [expr {1000000000000000000000000000i < 1000000000000001000000000000}]
+ lappend res [expr {1000000000000001000000000000 > 1000000000000000000000000000i}]
+ lappend res [expr {1000000000000001000000000000i > 1000000000000000000000000000}]
+ # Double
+ lappend res [expr {1.0 < 2i}]
+ lappend res [expr {1i < 2.0}]
+ lappend res [expr {2.0 > 1i}]
+ lappend res [expr {2i > 1.0}]
+} -result {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1}
+
+test expr-53.1 {complex functions} -body {
+ set a [expr {real(-5.0+3.0i)}]
+ lappend a [expr {real(3.0)}]
+ lappend a [expr {real(3.0i)}]
+ lappend a [expr {real(3)}]
+ lappend a [expr {real(12345678901234567890)}]
+} -result "-5.0 3.0 0.0 3 12345678901234567890"
+
+test expr-53.2 {complex functions} -body {
+ set a [expr {imag(-5.0+3.0i)}]
+ lappend a [expr {imag(3.0)}]
+ lappend a [expr {imag(3.0i)}]
+ lappend a [expr {imag(3)}]
+ lappend a [expr {imag(12345678901234567890)}]
+} -result "3.0 0.0 3.0 0 0"
+
+test expr-53.3 {complex functions} -body {
+ set a [expr {arg(-5.0+3.0i)}]
+ lappend a [expr {arg(3.0)}]
+ lappend a [expr {arg(-3.0)}]
+ lappend a [expr {arg(3.0i)}]
+ lappend a [expr {arg(3)}]
+ lappend a [expr {arg(-3)}]
+ lappend a [expr {arg(12345678901234567890)}]
+ lappend a [expr {arg(-12345678901234567890)}]
+} -result [list [expr {atan2(3,-5)}] \
+ 0.0 [expr {atan2(0,-1)}] \
+ [expr {atan2(1,0)}] \
+ 0.0 [expr {atan2(0,-1)}] \
+ 0.0 [expr {atan2(0,-1)}]]
+
+test expr-53.4 {complex functions} -body {
+ set a [expr {polar(1.0, 0.0)}]
+ lappend a [expr {imag(polar(2.0, 3.14159265358979/2))}]
+ lappend a [expr {real(polar(3.0, 3.14159265358979))}]
+} -result "1.0 2.0 -3.0"
+
+test expr-53.5 {complex functions} -body {
+ set a [expr {complex(1.0, 0.0)}]
+ lappend a [expr {complex(2.0, 3.5)}]
+ lappend a [expr {complex(3, -5)}]
+} -result "1.0 2.0_3.5i 3.0_-5.0i"
+
+test expr-53.6 {complex functions} -body {
+ set a [expr {norm(3.0_4.0i)}]
+ lappend a [expr {norm(-5)}]
+ lappend a [expr {norm(-5.0)}]
+ lappend a [expr {norm(2.0+5.0i)}]
+} -result "25.0 25 25.0 29.0"
+
+test expr-53.7 {complex functions} -body {
+ set a [expr {conj(3.0_4.0i)}]
+ lappend a [expr {conj(-5)}]
+ lappend a [expr {conj(-5.0)}]
+ lappend a [expr {conj(2.0+5.0i)}]
+} -result "3.0_-4.0i -5 -5.0 2.0_-5.0i"
# cleanup
if {[info exists a]} {
unset a
Index: tests/info.test
==================================================================
--- tests/info.test
+++ tests/info.test
@@ -653,20 +653,20 @@
namespace eval x info vars foo
} -cleanup {
namespace delete x
} -result {}
-set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isqrt log log10 max min pow rand round sin sinh sqrt srand tan tanh wide}
+set functions {abs acos arg asin atan atan2 bool ceil complex conj cos cosh double entier exp floor fmod hypot imag int isqrt log log10 max min norm polar pow rand real round sin sinh sqrt srand tan tanh wide}
# Check whether the extra testing functions are defined...
if {!([catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} {
set functions "T1 T2 T3 $functions" ;# A lazy way of prepending!
}
test info-20.1 {info functions option} {info functions sin} sin
test info-20.2 {info functions option} {lsort [info functions]} $functions
test info-20.3 {info functions option} {
lsort [info functions a*]
-} {abs acos asin atan atan2}
+} {abs acos arg asin atan atan2}
test info-20.4 {info functions option} {
lsort [info functions *tan*]
} {atan atan2 tan tanh}
test info-20.5 {info functions option} -returnCodes error -body {
info functions raise an error
Index: tests/namespace.test
==================================================================
--- tests/namespace.test
+++ tests/namespace.test
@@ -1782,12 +1782,15 @@
namespace ensemble create
}
list [ns x0 z] [ns x1] [ns x2] [ns x3]
} -cleanup {
namespace delete ns
-} -result {{1 ::ns::x0::z} 1 2 3}
-test namespace-42.8 {ensembles: [Bug 1670091]} -setup {
+} -result {{1 z} 1 2 3}
+test namespace-42.8 {
+ ensembles: [Bug 1670091], panic due to pointer to a deallocated List
+ struct.
+} -setup {
proc demo args {}
variable target [list [namespace which demo] x]
proc trial args {variable target; string length $target}
trace add execution demo enter [namespace code trial]
namespace ensemble create -command foo -map [list bar $target]
@@ -1798,10 +1801,23 @@
rename demo {}
rename trial {}
rename foo {}
} -result {}
+test namespace-42.9 {
+ ensembles: [Bug 4f6a1ebd64], segmentation fault due to pointer to a
+ deallocated List struct.
+} -setup {
+ namespace eval n {namespace ensemble create}
+ dict set list one ::two
+ namespace ensemble configure n -subcommands $list -map $list
+} -body {
+ n one
+} -cleanup {
+ namespace delete n
+} -returnCodes error -match glob -result {invalid command name*}
+
test namespace-43.1 {ensembles: dict-driven} {
namespace eval ns {
namespace export x*
proc x1 {} {format 1}
proc x2 {} {format 2}
@@ -1918,11 +1934,11 @@
namespace ensemble create -command foobar -subcommands {foobarcget foobarconfigure}
} -body {
foobar foobarcon
} -cleanup {
rename foobar {}
-} -returnCodes error -result {invalid command name "::foobarconfigure"}
+} -returnCodes error -result {invalid command name "foobarconfigure"}
test namespace-44.6 {ensemble: errors} -returnCodes error -body {
namespace ensemble create gorp
} -result {wrong # args: should be "namespace ensemble create ?option value ...?"}
test namespace-45.1 {ensemble: introspection} {
@@ -2082,11 +2098,11 @@
lappend result [catch {ns a b c} msg] $msg
lappend result [catch {ns b c d} msg] $msg
lappend result [catch {ns c d e} msg] $msg
lappend result [catch {ns Magic foo bar spong wibble} msg] $msg
list $result [lsort [info commands ::ns::*]] $log [namespace delete ns]
-} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ::ns::a b c} {running ::ns::a b c} {making b} {running ::ns::b c d} {making c} {running ::ns::c d e} {unknown Magic - args = foo bar spong wibble}} {}}
+} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running a b c} {running a b c} {making b} {running b c d} {making c} {running c d e} {unknown Magic - args = foo bar spong wibble}} {}}
test namespace-47.2 {ensemble: unknown handler} {
namespace eval ns {
namespace export {[a-z]*}
proc Magic {ensemble subcmd args} {
error foobar
@@ -3181,11 +3197,11 @@
} -result\
{0 0\
1 {wrong # args: should be "ns z1 x a1"}\
1 {wrong # args: should be "ns z2 x a1 a2"}\
1 {wrong # args: should be "ns z2 x a1 a2"}\
- 1 {wrong # args: should be "::ns::x::z0"}\
+ 1 {wrong # args: should be "z0"}\
0 {1 v}\
1 {wrong # args: should be "ns v x z2 a2"}\
0 {2 v v2}}
test namespace-53.11 {ensembles: nested rewrite} -setup {
namespace eval ns {
@@ -3265,10 +3281,22 @@
} finally {
namespace delete ::testing
}
}
} {::testing::abc::def ::testing::abc::ghi}
+
+test namespace-56.4 {bug 16fe1b5807: names starting with ":"} {
+namespace eval : {
+ namespace ensemble create
+ namespace export *
+ proc p1 {} {
+ return 16fe1b5807
+ }
+}
+
+: p1
+} 16fe1b5807
# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
Index: tests/package.test
==================================================================
--- tests/package.test
+++ tests/package.test
@@ -18,22 +18,23 @@
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-testConstraint testpreferstable [llength [info commands testpreferstable]]
-
# Do all this in a slave interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoSlaveInterpreter $i {*}$argv
+load {} Tcltest $i
interp eval $i {
namespace import -force ::tcltest::*
-package forget {*}[package names]
+#package forget {*}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
+
+testConstraint testpreferstable [llength [info commands testpreferstable]]
test package-1.1 {pkg::create gives error on insufficient args} -body {
::pkg::create
} -returnCodes error -match glob -result {wrong # args: should be "*"}
test package-1.2 {pkg::create gives error on bad args} -body {
@@ -137,51 +138,51 @@
} -body {
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {3.4}
test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
set x xxx
} -body {
foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {3.5}
test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
set x xxx
} -body {
foreach i {3.5 2.1 2.3} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t 2.2
- return $x
+ set x
} -result {2.3}
test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
set x xxx
} -body {
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require -exact t 2.3
- return $x
+ set x
} -result {2.3}
test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
set x xxx
} -body {
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t 2.1
- return $x
+ set x
} -result {2.4}
test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup {
package forget t
} -returnCodes error -body {
package unknown {}
@@ -236,11 +237,11 @@
package forget t
set x xxx
} -body {
package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2"
package require t 1.2
- return $x
+ set x
} -result {1.2}
test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup {
package forget t
set x xxx
} -body {
@@ -254,11 +255,11 @@
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i"
}
package unknown pkgUnknown
package require -exact t 1.5
- return $x
+ set x
} -cleanup {
package unknown {}
} -result {t 1.5-1.5}
test package-3.14 {Tcl_PkgRequire procedure, "package unknown" support} -setup {
package forget t
@@ -281,11 +282,11 @@
global x
set x $args
package provide [lindex $args 0] 2.0
}
package require {a b}
- return $x
+ set x
} -cleanup {
package unknown {}
} -result {{a b} 0-}
test package-3.16 {Tcl_PkgRequire procedure, "package unknown" error} -setup {
package forget t
@@ -573,73 +574,119 @@
package require -exact demo 1.2
} -returnCodes error -cleanup {
package forget demo
} -result {version conflict for package "demo": have 1.2.3, need exactly 1.2}
test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup {
+ interp create child
+ load {} Tcltest child
+ child eval {
testpreferstable
package forget t
set x xxx
+ }
} -body {
+ child eval {
foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
+ }
+} -cleanup {
+ interp delete child
} -result {3.4}
test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup {
package forget t
set x xxx
} -body {
foreach i {1.2b1 1.2 1.3a2 1.3} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {1.3}
test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup {
package forget t
set x xxx
} -body {
foreach i {1.2b1 1.2 1.3 1.3a2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {1.3}
+test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup {
+ testpreferstable
+ package forget t
+ set x xxx
+} -body {
+ foreach i {1.2b1 1.1} {
+ package ifneeded t $i "set x $i; package provide t $i"
+ }
+ package require t
+ set x
+} -result {1.1}
+
test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body {
package
} -result {wrong # args: should be "package option ?arg ...?"}
-test package-4.2 {Tcl_PackageCmd procedure, "forget" option} {
+test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
package names
-} {}
-test package-4.3 {Tcl_PackageCmd procedure, "forget" option} {
+ }
+} -cleanup {
+ interp delete child
+} -result {}
+test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
package forget foo
-} {}
+ }
+} -cleanup {
+ interp delete child
+} -result {}
test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+ child eval {
package forget {*}[package names]
set result {}
+ }
} -body {
+ child eval {
package ifneeded t 1.1 {first script}
package ifneeded t 2.3 {second script}
package ifneeded x 1.4 {x's script}
lappend result [lsort [package names]] [package versions t]
package forget t
lappend result [lsort [package names]] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {{t x} {1.1 2.3} x {}}
test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+ child eval {
package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded a 1.1 {first script}
package ifneeded b 2.3 {second script}
package ifneeded c 1.4 {third script}
package forget
set result [list [lsort [package names]]]
package forget a c
lappend result [lsort [package names]]
+ }
+} -cleanup {
+ interp delete child
} -result {{a b c} b}
test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body {
# Test for Bug 415273
package ifneeded a 1 "I should have been forgotten"
package forget no-such-package a
@@ -654,32 +701,59 @@
package ifneeded a b c d
} -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"}
test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body {
package ifneeded t xyz
} -returnCodes error -result {expected version number but got "xyz"}
-test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} {
+test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
list [package ifneeded foo 1.1] [package names]
-} {{} {}}
+ }
+} -cleanup {
+ interp delete child
+} -result {{} {}}
test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
- package forget t
+ interp create child
+ child eval {
+ package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded t 1.4 "script for t 1.4"
list [package names] [package ifneeded t 1.4] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {t {script for t 1.4} 1.4}
test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
- package forget t
+ interp create child
+ child eval {
+ package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded t 1.4 "script for t 1.4"
list [package ifneeded t 1.5] [package names] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {{} t 1.4}
test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
- package forget t
+ interp create child
+ child eval {
+ package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded t 1.4 "script for t 1.4"
package ifneeded t 1.4 "second script for t 1.4"
list [package ifneeded t 1.4] [package names] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {{second script for t 1.4} t 1.4}
test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
package forget t
} -body {
package ifneeded t 1.4 "script for t 1.4"
@@ -688,22 +762,35 @@
list [package ifneeded t 1.2] [package versions t]
} -result {{second script} {1.4 1.2 3.1}}
test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body {
package names a
} -returnCodes error -result {wrong # args: should be "package names"}
-test package-4.15 {Tcl_PackageCmd procedure, "names" option} {
+test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
package names
-} {}
+ }
+} -cleanup {
+ interp delete child
+} -result {}
test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup {
+ interp create child
+ child eval {
package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded x 1.2 {dummy}
package provide x 1.3
package provide y 2.4
catch {package require z 47.16}
lsort [package names]
+ }
+} -cleanup {
+ interp delete child
} -result {x y}
test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body {
package provide
} -returnCodes error -result {wrong # args: should be "package provide package ?version?"}
test package-4.18 {Tcl_PackageCmd procedure, "provide" option} -body {
@@ -1237,15 +1324,13 @@
} finally {
interp delete $ip
}
}
-test package-13.0 {package prefer defaults} -constraints testpreferstable -setup {
- testpreferstable
-} -body {
+test package-13.0 {package prefer defaults} -body {
prefer
-} -result stable
+} -result [expr {[string match {*[ab]*} [package provide Tcl]] ? "latest" : "stable"}]
test package-13.1 {package prefer defaults} -body {
set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant!
prefer
} -cleanup {
unset -nocomplain ::env(TCL_PKG_PREFER_LATEST)
@@ -1258,27 +1343,29 @@
package prefer foo
} -result {bad preference "foo": must be latest or stable}
test package-15.0 {set, keep} -constraints testpreferstable -setup {
testpreferstable
-} -body {package prefer stable} -result stable
+} -body {package prefer} -result stable
test package-15.1 {set stable, keep} -constraints testpreferstable -setup {
testpreferstable
-} -body {prefer stable} -result {stable stable}
+} -body {package prefer stable} -result stable
test package-15.2 {set latest, change} -constraints testpreferstable -setup {
testpreferstable
-} -body {prefer latest} -result {stable latest}
+} -body {package prefer latest} -result latest
test package-15.3 {set latest, keep} -constraints testpreferstable -setup {
testpreferstable
} -body {
- prefer latest latest
-} -result {stable latest latest}
+ package prefer latest
+ package prefer latest
+} -result latest
test package-15.4 {set stable, rejected} -constraints testpreferstable -setup {
testpreferstable
} -body {
- prefer latest stable
-} -result {stable latest latest}
+ package prefer latest
+ package prefer stable
+} -result latest
rename prefer {}
set auto_path $oldPath
package unknown $oldPkgUnknown
Index: tests/split.test
==================================================================
--- tests/split.test
+++ tests/split.test
@@ -68,10 +68,13 @@
split "12,34,56," {,}
} {12 34 56 {}}
test split-1.14 {basic split commands} {
split ",12,,,34,56," {,}
} {{} 12 {} {} 34 56 {}}
+test split-1.15 {basic split commands} -body {
+ split "a\U01f4a9b" {}
+} -result "a \U01f4a9 b"
test split-2.1 {split errors} {
list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}}
test split-2.2 {split errors} {
Index: tests/string.test
==================================================================
--- tests/string.test
+++ tests/string.test
@@ -26,10 +26,15 @@
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
+proc representationpoke s {
+ set r [::tcl::unsupported::representation $s]
+ list [lindex $r 3] [string match {*, string representation "*"} $r]
+}
+
test string-1.1 {error conditions} {
list [catch {string gorp a b} msg] $msg
} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
list [catch {string} msg] $msg
@@ -222,10 +227,17 @@
# strings was incorrect, leading to an index returned by [string first]
# which pointed past the end of the string.
set uchar \u057e ;# character with two-byte encoding in utf-8
string first % %#$uchar$uchar#$uchar$uchar#% 3
} 8
+test string-4.16 {string first, normal string vs pure unicode string} {
+ set s hello
+ regexp ll $s m
+ # Representation checks are canaries
+ list [representationpoke $s] [representationpoke $m] \
+ [string first $m $s]
+} {{string 1} {string 0} 2}
test string-5.1 {string index} {
list [catch {string index} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.2 {string index} {
@@ -313,14 +325,14 @@
test string-6.4 {string is, too many args} {
list [catch {string is alpha -failin var -strict str more} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.5 {string is, class check} {
list [catch {string is bogus str} msg] $msg
-} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {bad class "bogus": must be alnum, alpha, ascii, complex, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
test string-6.6 {string is, ambiguous class} {
list [catch {string is al str} msg] $msg
-} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {ambiguous class "al": must be alnum, alpha, ascii, complex, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
test string-6.7 {string is alpha, all ok} {
string is alpha -strict -failindex var abc
} 1
test string-6.8 {string is, error in var} {
list [string is alpha -failindex var abc5def] $var
@@ -749,10 +761,18 @@
list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
} {0 87}
test string-6.131 {string is entier, false on bad hex} {
list [string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ] $var
} {0 88}
+test string-6.132 {string is complex} -body {
+ set res {}
+ foreach val {1.0 { 3.5 } 1i 2.0i 1.0_3.5i { 2.0_-2.2i } 3.1x 2.0_2.0x 2.1_3.5ix} {
+ lappend res [string is double $val]
+ lappend res [string is complex $val]
+ }
+ set res
+} -result {1 1 1 1 0 1 0 1 0 1 0 1 0 0 0 0 0 0}
catch {rename largest_int {}}
test string-7.1 {string last, too few args} {
list [catch {string last a} msg] $msg
@@ -1683,44 +1703,44 @@
set x abc
set y de
string reverse $x$y
} edcba
test string-24.5 {string reverse command - shared unicode string} {
- set x abcde\udead
+ set x abcde\ud0ad
string reverse $x
-} \udeadedcba
+} \ud0adedcba
test string-24.6 {string reverse command - unshared string} {
set x abc
- set y de\udead
+ set y de\ud0ad
string reverse $x$y
-} \udeadedcba
+} \ud0adedcba
test string-24.7 {string reverse command - simple case} {
string reverse a
} a
test string-24.8 {string reverse command - simple case} {
- string reverse \udead
-} \udead
+ string reverse \ud0ad
+} \ud0ad
test string-24.9 {string reverse command - simple case} {
string reverse {}
} {}
test string-24.10 {string reverse command - corner case} {
- set x \ubeef\udead
+ set x \ubeef\ud0ad
string reverse $x
-} \udead\ubeef
+} \ud0ad\ubeef
test string-24.11 {string reverse command - corner case} {
set x \ubeef
- set y \udead
+ set y \ud0ad
string reverse $x$y
-} \udead\ubeef
+} \ud0ad\ubeef
test string-24.12 {string reverse command - corner case} {
set x \ubeef
- set y \udead
+ set y \ud0ad
string is ascii [string reverse $x$y]
} 0
test string-24.13 {string reverse command - pure Unicode string} {
- string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5]
-} \udead\ubeef\udead\ubeef\udead
+ string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5]
+} \ud0ad\ubeef\ud0ad\ubeef\ud0ad
test string-24.14 {string reverse command - pure bytearray} {
binary scan [string reverse [binary format H* 010203]] H* x
set x
} 030201
test string-24.15 {string reverse command - pure bytearray} {
@@ -2040,17 +2060,15 @@
} -cleanup {
unset e f
} -body {
tcl::unsupported::representation [string cat $e $f $e $f [list x]]
} -match glob -result {*no string representation}
-
-
-
+
# cleanup
rename MemStress {}
catch {rename foo {}}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
Index: tests/stringObj.test
==================================================================
--- tests/stringObj.test
+++ tests/stringObj.test
@@ -478,14 +478,17 @@
} fooo
test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj {
teststringobj set 1 foo
teststringobj appendself2 1 3
} foo
-
if {[testConstraint testobj]} {
testobj freeallvars
}
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
Index: tests/utf.test
==================================================================
--- tests/utf.test
+++ tests/utf.test
@@ -66,14 +66,14 @@
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
string length [testbytestring "\xE4\xb9\x8e"]
} {1}
test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
string length [testbytestring "\xF0\x90\x80\x80"]
-} -result {1}
+} -result {2}
test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
string length [testbytestring "\xF4\x8F\xBF\xBF"]
-} -result {1}
+} -result {2}
test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
string length [testbytestring "\xF0\x8F\xBF\xBF"]
} {4}
test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring {
string length [testbytestring "\xF4\x90\x80\x80"]
Index: unix/Makefile.in
==================================================================
--- unix/Makefile.in
+++ unix/Makefile.in
@@ -855,12 +855,12 @@
do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
done;
@echo "Installing package msgcat 1.6.1 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm;
- @echo "Installing package tcltest 2.4.0 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.0.tm;
+ @echo "Installing package tcltest 2.4.1 as a Tcl Module";
+ @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm;
@echo "Installing package platform 1.0.14 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm;
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;
Index: unix/configure
==================================================================
--- unix/configure
+++ unix/configure
@@ -3730,30 +3730,10 @@
if test $tcl_cv_dirent_h = no; then
$as_echo "#define NO_DIRENT_H 1" >>confdefs.h
fi
-
- ac_fn_c_check_header_mongrel "$LINENO" "float.h" "ac_cv_header_float_h" "$ac_includes_default"
-if test "x$ac_cv_header_float_h" = xyes; then :
-
-else
-
-$as_echo "#define NO_FLOAT_H 1" >>confdefs.h
-
-fi
-
-
- ac_fn_c_check_header_mongrel "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default"
-if test "x$ac_cv_header_values_h" = xyes; then :
-
-else
-
-$as_echo "#define NO_VALUES_H 1" >>confdefs.h
-
-fi
-
ac_fn_c_check_header_mongrel "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default"
if test "x$ac_cv_header_stdlib_h" = xyes; then :
tcl_ok=1
else
Index: unix/tcl.m4
==================================================================
--- unix/tcl.m4
+++ unix/tcl.m4
@@ -2038,11 +2038,10 @@
#
# Results:
#
# Defines some of the following vars:
# NO_DIRENT_H
-# NO_VALUES_H
# NO_STDLIB_H
# NO_STRING_H
# NO_SYS_WAIT_H
# NO_DLFCN_H
# HAVE_SYS_PARAM_H
@@ -2076,12 +2075,10 @@
if test $tcl_cv_dirent_h = no; then
AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?])
fi
- AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have ?])])
- AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])])
AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0)
AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0)
AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0)
AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0)
if test $tcl_ok = 0; then
Index: unix/tclConfig.h.in
==================================================================
--- unix/tclConfig.h.in
+++ unix/tclConfig.h.in
@@ -293,13 +293,10 @@
#undef NO_DLFCN_H
/* Do we have fd_set? */
#undef NO_FD_SET
-/* Do we have ? */
-#undef NO_FLOAT_H
-
/* Do we have fstatfs()? */
#undef NO_FSTATFS
/* Do we have gettimeofday()? */
#undef NO_GETTOD
@@ -332,13 +329,10 @@
#undef NO_UNAME
/* Do we have a usable 'union wait'? */
#undef NO_UNION_WAIT
-/* Do we have ? */
-#undef NO_VALUES_H
-
/* Do we have wait3() */
#undef NO_WAIT3
/* Define to the address where bug reports for this package should be sent. */
#undef PACKAGE_BUGREPORT
Index: unix/tclUnixPort.h
==================================================================
--- unix/tclUnixPort.h
+++ unix/tclUnixPort.h
@@ -179,17 +179,11 @@
* for an alternative definition. If no other alternative is available we use
* a reasonable guess.
*---------------------------------------------------------------------------
*/
-#ifndef NO_FLOAT_H
-# include
-#else
-#ifndef NO_VALUES_H
-# include
-#endif
-#endif
+#include
#ifndef FLT_MAX
# ifdef MAXFLOAT
# define FLT_MAX MAXFLOAT
# else
Index: unix/tclUnixThrd.c
==================================================================
--- unix/tclUnixThrd.c
+++ unix/tclUnixThrd.c
@@ -13,15 +13,17 @@
#include "tclInt.h"
#ifdef TCL_THREADS
+#ifndef TCL_NO_DEPRECATED
typedef struct {
char nabuf[16];
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
+#endif
/*
* masterLock is used to serialize creation of mutexes, condition variables,
* and thread local storage. This is the only place that can count on the
* ability to statically initialize the mutex.
Index: win/tcl.dsp
==================================================================
--- win/tcl.dsp
+++ win/tcl.dsp
@@ -148,14 +148,10 @@
# End Source File
# Begin Source File
SOURCE=..\compat\fixstrtod.c
# End Source File
-# Begin Source File
-
-SOURCE=..\compat\float.h
-# End Source File
# Begin Source File
SOURCE=..\compat\gettod.c
# End Source File
# Begin Source File
Index: win/tcl.hpj.in
==================================================================
--- win/tcl.hpj.in
+++ win/tcl.hpj.in
@@ -3,17 +3,17 @@
[OPTIONS]
HCW=0
LCID=0x409 0x0 0x0 ;English (United States)
REPORT=Yes
TITLE=Tcl/Tk Reference Manual
-CNT=tcl86.cnt
+CNT=tcl87.cnt
COPYRIGHT=Copyright © 2000 Ajuba Solutions
-HLP=tcl86.hlp
+HLP=tcl87.hlp
[FILES]
tcl.rtf
[WINDOWS]
main="Tcl/Tk Reference Manual",,0
[CONFIG]
BrowseButtons()
Index: win/tclWinError.c
==================================================================
--- win/tclWinError.c
+++ win/tclWinError.c
@@ -28,11 +28,11 @@
ENOMEM, /* ERROR_INVALID_BLOCK 9 */
E2BIG, /* ERROR_BAD_ENVIRONMENT 10 */
ENOEXEC, /* ERROR_BAD_FORMAT 11 */
EACCES, /* ERROR_INVALID_ACCESS 12 */
EINVAL, /* ERROR_INVALID_DATA 13 */
- EFAULT, /* ERROR_OUT_OF_MEMORY 14 */
+ ENOMEM, /* ERROR_OUT_OF_MEMORY 14 */
ENOENT, /* ERROR_INVALID_DRIVE 15 */
EACCES, /* ERROR_CURRENT_DIRECTORY 16 */
EXDEV, /* ERROR_NOT_SAME_DEVICE 17 */
ENOENT, /* ERROR_NO_MORE_FILES 18 */
EROFS, /* ERROR_WRITE_PROTECT 19 */
Index: win/tclWinThrd.c
==================================================================
--- win/tclWinThrd.c
+++ win/tclWinThrd.c
@@ -11,12 +11,10 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclWinInt.h"
-#include
-
/* Workaround for mingw versions which don't provide this in float.h */
#ifndef _MCW_EM
# define _MCW_EM 0x0008001F /* Error masks */
# define _MCW_RC 0x00000300 /* Rounding */
# define _MCW_PC 0x00030000 /* Precision */