summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2018-01-25 16:51:29 (GMT)
committerdgp <dgp@users.sourceforge.net>2018-01-25 16:51:29 (GMT)
commiteb9e2858c160aa46fea8ce4eebd1354eaec2f76e (patch)
treeb8939af4b8d99bb3787e2753e9a1c9e7ff359b7f
parentfc03549d341d28a2158b38acb91c75be993d37d0 (diff)
parent92aca935b38217e0b34c9fcc83d732eec5f1dd92 (diff)
downloadtcl-eb9e2858c160aa46fea8ce4eebd1354eaec2f76e.zip
tcl-eb9e2858c160aa46fea8ce4eebd1354eaec2f76e.tar.gz
tcl-eb9e2858c160aa46fea8ce4eebd1354eaec2f76e.tar.bz2
merge 8.7
-rw-r--r--doc/Interp.32
-rw-r--r--doc/format.n4
-rw-r--r--generic/tcl.decls96
-rw-r--r--generic/tcl.h76
-rw-r--r--generic/tclBasic.c23
-rw-r--r--generic/tclCmdAH.c2
-rw-r--r--generic/tclCmdMZ.c1
-rw-r--r--generic/tclDecls.h212
-rw-r--r--generic/tclEncoding.c2
-rw-r--r--generic/tclEvent.c1
-rw-r--r--generic/tclIOCmd.c6
-rw-r--r--generic/tclIOUtil.c9
-rw-r--r--generic/tclInt.decls10
-rw-r--r--generic/tclInt.h33
-rw-r--r--generic/tclIntDecls.h14
-rw-r--r--generic/tclIntPlatDecls.h16
-rw-r--r--generic/tclOO.c785
-rw-r--r--generic/tclOOCall.c13
-rw-r--r--generic/tclOODefineCmds.c133
-rw-r--r--generic/tclOOInt.h46
-rw-r--r--generic/tclObj.c8
-rw-r--r--generic/tclPkg.c5
-rw-r--r--generic/tclStringObj.c13
-rw-r--r--generic/tclStubInit.c60
-rw-r--r--generic/tclTest.c163
-rw-r--r--generic/tclUtf.c24
-rw-r--r--generic/tclUtil.c2
-rw-r--r--tests/compExpr-old.test22
-rw-r--r--tests/compExpr.test12
-rw-r--r--tests/expr-old.test17
-rw-r--r--tests/expr.test39
-rw-r--r--tests/oo.test13
-rw-r--r--tests/safe.test8
-rw-r--r--tests/string.test4
-rw-r--r--unix/tclUnixInit.c6
-rw-r--r--win/tclWin32Dll.c76
-rw-r--r--win/tclWinDde.c7
-rw-r--r--win/tclWinInit.c7
38 files changed, 863 insertions, 1107 deletions
diff --git a/doc/Interp.3 b/doc/Interp.3
index 731007b..4ccff21 100644
--- a/doc/Interp.3
+++ b/doc/Interp.3
@@ -101,7 +101,7 @@ the command. The \fIfreeProc\fR field will be initialized to zero,
and \fIinterp->result\fR will point to an empty string. Commands that
do not return any value can simply leave the fields alone.
Furthermore, the empty string pointed to by \fIresult\fR is actually
-part of an array of \fBTCL_RESULT_SIZE\fR characters (approximately 200).
+part of an array of approximately 200 characters.
If a command wishes to return a short string, it can simply copy
it to the area pointed to by \fIinterp->result\fR. Or, it can use
the sprintf procedure to generate a short result string at the location
diff --git a/doc/format.n b/doc/format.n
index 4eb566d..6f5f7bd 100644
--- a/doc/format.n
+++ b/doc/format.n
@@ -83,7 +83,7 @@ Specifies that the number should be padded on the left with
zeroes instead of spaces.
.TP 10
\fB#\fR
-Requests an alternate output form. For \fBo\fR and \fBO\fR
+Requests an alternate output form. For \fBo\fR
conversions it guarantees that the first digit is always \fB0\fR.
For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively)
will be added to the beginning of the result unless it is zero.
@@ -171,7 +171,7 @@ for \fBx\fR and
for \fBX\fR).
.TP 10
\fBb\fR
-Convert integer to binary string, using digits 0 and 1.
+Convert integer to unsigned binary string, using digits 0 and 1.
.TP 10
\fBc\fR
Convert integer to the Unicode character it represents.
diff --git a/generic/tcl.decls b/generic/tcl.decls
index f2850fa..60aebfd 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -32,7 +32,7 @@ declare 0 {
const char *version, const void *clientData)
}
declare 1 {
- CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp,
+ const char *Tcl_PkgRequireEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
@@ -154,7 +154,7 @@ declare 35 {
}
declare 36 {
int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr)
+ const char *const *tablePtr, const char *msg, int flags, int *indexPtr)
}
declare 37 {
int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
@@ -285,7 +285,7 @@ declare 75 {
declare 76 {
void Tcl_BackgroundError(Tcl_Interp *interp)
}
-declare 77 {
+declare 77 {deprecated {Use Tcl_UtfBackslash}} {
char Tcl_Backslash(const char *src, int *readPtr)
}
declare 78 {
@@ -306,7 +306,7 @@ declare 82 {
int Tcl_CommandComplete(const char *cmd)
}
declare 83 {
- char *Tcl_Concat(int argc, CONST84 char *const *argv)
+ char *Tcl_Concat(int argc, const char *const *argv)
}
declare 84 {
int Tcl_ConvertElement(const char *src, char *dst, int flags)
@@ -318,7 +318,7 @@ declare 85 {
declare 86 {
int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd,
Tcl_Interp *target, const char *targetCmd, int argc,
- CONST84 char *const *argv)
+ const char *const *argv)
}
declare 87 {
int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd,
@@ -352,7 +352,7 @@ declare 93 {
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
-declare 95 {
+declare 95 {deprecated {}} {
void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name,
int numArgs, Tcl_ValueType *argTypes,
Tcl_MathProc *proc, ClientData clientData)
@@ -461,10 +461,10 @@ declare 126 {
int Tcl_Eof(Tcl_Channel chan)
}
declare 127 {
- CONST84_RETURN char *Tcl_ErrnoId(void)
+ const char *Tcl_ErrnoId(void)
}
declare 128 {
- CONST84_RETURN char *Tcl_ErrnoMsg(int err)
+ const char *Tcl_ErrnoMsg(int err)
}
declare 129 {
int Tcl_Eval(Tcl_Interp *interp, const char *script)
@@ -528,12 +528,12 @@ declare 147 {
}
declare 148 {
int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd,
- Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
- int *argcPtr, CONST84 char ***argvPtr)
+ Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
+ int *argcPtr, const char ***argvPtr)
}
declare 149 {
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd,
- Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
+ Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 {
@@ -558,7 +558,7 @@ declare 155 {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 {
- CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan)
+ const char *Tcl_GetChannelName(Tcl_Channel chan)
}
declare 157 {
int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
@@ -572,14 +572,14 @@ declare 159 {
Tcl_CmdInfo *infoPtr)
}
declare 160 {
- CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp,
+ const char *Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command)
}
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
- CONST84_RETURN char *Tcl_GetHostName(void)
+ const char *Tcl_GetHostName(void)
}
declare 163 {
int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp)
@@ -622,14 +622,14 @@ declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 {
- CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp)
+ const char *Tcl_GetStringResult(Tcl_Interp *interp)
}
declare 175 {
- CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
+ const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags)
}
declare 176 {
- CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
+ const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 177 {
@@ -662,7 +662,7 @@ declare 185 {
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
- char *Tcl_JoinPath(int argc, CONST84 char *const *argv,
+ char *Tcl_JoinPath(int argc, const char *const *argv,
Tcl_DString *resultPtr)
}
declare 187 {
@@ -685,7 +685,7 @@ declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket)
}
declare 192 {
- char *Tcl_Merge(int argc, CONST84 char *const *argv)
+ char *Tcl_Merge(int argc, const char *const *argv)
}
declare 193 {
Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
@@ -703,7 +703,7 @@ declare 196 {
}
declare 197 {
Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
- CONST84 char **argv, int flags)
+ const char **argv, int flags)
}
# This is obsolete, use Tcl_FSOpenFileChannel
declare 198 {
@@ -729,7 +729,7 @@ declare 203 {
int Tcl_PutEnv(const char *assignment)
}
declare 204 {
- CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp)
+ const char *Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 {
void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
@@ -765,7 +765,7 @@ declare 214 {
}
declare 215 {
void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
- CONST84 char **startPtr, CONST84 char **endPtr)
+ const char **startPtr, const char **endPtr)
}
declare 216 {
void Tcl_Release(ClientData clientData)
@@ -835,29 +835,29 @@ declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 237 {
- CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
+ const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags)
}
declare 238 {
- CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
+ const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue, int flags)
}
declare 239 {
- CONST84_RETURN char *Tcl_SignalId(int sig)
+ const char *Tcl_SignalId(int sig)
}
declare 240 {
- CONST84_RETURN char *Tcl_SignalMsg(int sig)
+ const char *Tcl_SignalMsg(int sig)
}
declare 241 {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 {
int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
- CONST84 char ***argvPtr)
+ const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
- void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr)
+ void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr)
}
declare 244 {
void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName,
@@ -952,15 +952,15 @@ declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 {
- CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
- CONST84 char **termPtr)
+ const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
+ const char **termPtr)
}
declare 271 {
- CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+ const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
declare 272 {
- CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp,
+ const char *Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
@@ -970,7 +970,7 @@ declare 273 {
}
# 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 *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
declare 275 {deprecated {see TIP #422}} {
@@ -1084,7 +1084,7 @@ declare 301 {
Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name)
}
declare 302 {
- CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding)
+ const char *Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 {
void Tcl_GetEncodingNames(Tcl_Interp *interp)
@@ -1160,7 +1160,7 @@ declare 324 {
int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 {
- CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index)
+ const char *Tcl_UtfAtIndex(const char *src, int index)
}
declare 326 {
int Tcl_UtfCharComplete(const char *src, int length)
@@ -1169,16 +1169,16 @@ declare 327 {
int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst)
}
declare 328 {
- CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch)
+ const char *Tcl_UtfFindFirst(const char *src, int ch)
}
declare 329 {
- CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch)
+ const char *Tcl_UtfFindLast(const char *src, int ch)
}
declare 330 {
- CONST84_RETURN char *Tcl_UtfNext(const char *src)
+ const char *Tcl_UtfNext(const char *src)
}
declare 331 {
- CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start)
+ const char *Tcl_UtfPrev(const char *src, const char *start)
}
declare 332 {
int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
@@ -1211,10 +1211,10 @@ declare 339 {
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
-declare 341 {
- CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void)
+declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} {
+ const char *Tcl_GetDefaultEncodingDir(void)
}
-declare 342 {
+declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} {
void Tcl_SetDefaultEncodingDir(const char *path)
}
declare 343 {
@@ -1263,7 +1263,7 @@ declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
-declare 357 {
+declare 357 {deprecated {Use Tcl_EvalTokensStandard}} {
Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count)
}
@@ -1276,7 +1276,7 @@ declare 359 {
}
declare 360 {
int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes,
- Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)
+ Tcl_Parse *parsePtr, int append, const char **termPtr)
}
declare 361 {
int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes,
@@ -1289,7 +1289,7 @@ declare 362 {
declare 363 {
int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start,
int numBytes, Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr)
+ const char **termPtr)
}
declare 364 {
int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes,
@@ -1405,7 +1405,7 @@ declare 397 {
int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 {
- CONST84_RETURN char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr)
+ const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr)
}
declare 399 {
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
@@ -1545,12 +1545,12 @@ declare 434 {
}
# TIP#15 (math function introspection) dkf
-declare 435 {
+declare 435 {deprecated {}} {
int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name,
int *numArgsPtr, Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr, ClientData *clientDataPtr)
}
-declare 436 {
+declare 436 {deprecated {}} {
Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern)
}
diff --git a/generic/tcl.h b/generic/tcl.h
index a6a8c94..2ce504f 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -137,7 +137,7 @@ extern "C" {
*/
#include <stdarg.h>
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# define TCL_VARARGS(type, name) (type name, ...)
# define TCL_VARARGS_DEF(type, name) (type name, ...)
# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
@@ -254,10 +254,9 @@ extern "C" {
* New code should use prototypes.
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# undef _ANSI_ARGS_
# define _ANSI_ARGS_(x) x
-#endif /* !TCL_NO_DEPRECATED */
/*
* Definitions that allow this header file to be used either with or without
@@ -267,34 +266,16 @@ extern "C" {
#ifndef INLINE
# define INLINE
#endif
-
-#ifdef NO_CONST
-# ifndef const
-# define const
-# endif
-#endif
#ifndef CONST
# define CONST const
#endif
+#define CONST84 const
+#define CONST84_RETURN const
-#ifdef USE_NON_CONST
-# ifdef USE_COMPAT_CONST
-# error define at most one of USE_NON_CONST and USE_COMPAT_CONST
-# endif
-# define CONST84
-# define CONST84_RETURN
-#else
-# ifdef USE_COMPAT_CONST
-# define CONST84
-# define CONST84_RETURN const
-# else
-# define CONST84 const
-# define CONST84_RETURN const
-# endif
-#endif
+#endif /* !TCL_NO_DEPRECATED */
#ifndef CONST86
-# define CONST86 CONST84
+# define CONST86 const
#endif
/*
@@ -318,6 +299,7 @@ extern "C" {
* VOID. This block is skipped under Cygwin and Mingw.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID)
#ifndef VOID
#define VOID void
@@ -333,23 +315,16 @@ typedef long LONG;
*/
#ifndef __VXWORKS__
-# ifndef NO_VOID
-# define VOID void
-# else
-# define VOID char
-# endif
+# define VOID void
#endif
+#endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */
/*
* Miscellaneous declarations.
*/
#ifndef _CLIENTDATA
-# ifndef NO_VOID
- typedef void *ClientData;
-# else
- typedef int *ClientData;
-# endif
+ typedef void *ClientData;
# define _CLIENTDATA
#endif
@@ -493,7 +468,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
*/
typedef struct Tcl_Interp
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{
/* TIP #330: Strongly discourage extensions from using the string
* result. */
@@ -673,7 +648,9 @@ typedef struct stat *Tcl_OldStat_;
#define TCL_BREAK 3
#define TCL_CONTINUE 4
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TCL_RESULT_SIZE 200
+#endif
/*
*----------------------------------------------------------------------------
@@ -689,6 +666,7 @@ typedef struct stat *Tcl_OldStat_;
* Argument descriptors for math function callbacks in expressions:
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
typedef enum {
TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
} Tcl_ValueType;
@@ -700,6 +678,10 @@ typedef struct Tcl_Value {
double doubleValue; /* Double-precision floating value. */
Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */
} Tcl_Value;
+#else
+#define Tcl_ValueType void /* Just enough to prevent compilation error in Tcl */
+#define Tcl_Value void /* Just enough to prevent compilation error in Tcl */
+#endif
/*
* Forward declaration of Tcl_Obj to prevent an error when the forward
@@ -720,10 +702,10 @@ typedef void (Tcl_ChannelProc) (ClientData clientData, int mask);
typedef void (Tcl_CloseProc) (ClientData data);
typedef void (Tcl_CmdDeleteProc) (ClientData clientData);
typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp,
- int argc, CONST84 char *argv[]);
+ int argc, const char *argv[]);
typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *proc,
- ClientData cmdClientData, int argc, CONST84 char *argv[]);
+ ClientData cmdClientData, int argc, const char *argv[]);
typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp,
int level, const char *command, Tcl_Command commandInfo, int objc,
struct Tcl_Obj *const *objv);
@@ -760,7 +742,7 @@ typedef void (Tcl_TimerProc) (ClientData clientData);
typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr);
typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr);
typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp,
- CONST84 char *part1, CONST84 char *part2, int flags);
+ const char *part1, const char *part2, int flags);
typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp,
const char *oldName, const char *newName, int flags);
typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc,
@@ -871,7 +853,7 @@ typedef struct Tcl_SavedResult {
char *appendResult;
int appendAvl;
int appendUsed;
- char resultSpace[TCL_RESULT_SIZE+1];
+ char resultSpace[200+1];
} Tcl_SavedResult;
/*
@@ -997,7 +979,7 @@ typedef struct Tcl_DString {
#define Tcl_DStringLength(dsPtr) ((dsPtr)->length)
#define Tcl_DStringValue(dsPtr) ((dsPtr)->string)
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# define Tcl_DStringTrunc Tcl_DStringSetLength
#endif /* !TCL_NO_DEPRECATED */
@@ -1125,7 +1107,7 @@ typedef struct Tcl_DString {
* give the flag)
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# define TCL_PARSE_PART1 0x400
#endif /* !TCL_NO_DEPRECATED */
@@ -1478,14 +1460,14 @@ typedef int (Tcl_DriverClose2Proc) (ClientData instanceData,
typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf,
int toRead, int *errorCodePtr);
typedef int (Tcl_DriverOutputProc) (ClientData instanceData,
- CONST84 char *buf, int toWrite, int *errorCodePtr);
+ const char *buf, int toWrite, int *errorCodePtr);
typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset,
int mode, int *errorCodePtr);
typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData,
- Tcl_Interp *interp, CONST84 char *optionName,
+ Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask);
typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData,
@@ -1978,7 +1960,7 @@ typedef struct Tcl_Token {
* TCL_TOKEN_OPERATOR - The token describes one expression operator.
* An operator might be the name of a math
* function such as "abs". A TCL_TOKEN_OPERATOR
- * token is always preceeded by one
+ * token is always preceded by one
* TCL_TOKEN_SUB_EXPR token for the operator's
* subexpression, and is followed by zero or more
* TCL_TOKEN_SUB_EXPR tokens for the operator's
@@ -2628,10 +2610,10 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
* Deprecated Tcl functions:
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* These function have been renamed. The old names are deprecated, but we
- * define these macros for backwards compatibilty.
+ * define these macros for backwards compatibility.
*/
# define Tcl_Ckalloc Tcl_Alloc
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 3ed3447..fa54551 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -132,8 +132,10 @@ static Tcl_NRPostProc NRCoroutineCallerCallback;
static Tcl_NRPostProc NRCoroutineExitCallback;
static Tcl_NRPostProc NRCommand;
+#if !defined(TCL_NO_DEPRECATED)
static Tcl_ObjCmdProc OldMathFuncProc;
static void OldMathFuncDeleteProc(ClientData clientData);
+#endif /* !defined(TCL_NO_DEPRECATED) */
static void ProcessUnexpectedResult(Tcl_Interp *interp,
int returnCode);
static int RewindCoroutine(CoroutineData *corPtr, int result);
@@ -205,7 +207,7 @@ static const CmdInfo builtInCmds[] = {
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
{"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE},
{"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE},
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
@@ -2626,10 +2628,6 @@ TclRenameCommand(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL);
return TCL_ERROR;
}
- cmdNsPtr = cmdPtr->nsPtr;
- oldFullName = Tcl_NewObj();
- Tcl_IncrRefCount(oldFullName);
- Tcl_GetCommandFullName(interp, cmd, oldFullName);
/*
* If the new command name is NULL or empty, delete the command. Do this
@@ -2638,10 +2636,14 @@ TclRenameCommand(
if ((newName == NULL) || (*newName == '\0')) {
Tcl_DeleteCommandFromToken(interp, cmd);
- result = TCL_OK;
- goto done;
+ return TCL_OK;
}
+ cmdNsPtr = cmdPtr->nsPtr;
+ oldFullName = Tcl_NewObj();
+ Tcl_IncrRefCount(oldFullName);
+ Tcl_GetCommandFullName(interp, cmd, oldFullName);
+
/*
* Make sure that the destination command does not already exist. The
* rename operation is like creating a command, so we should automatically
@@ -3154,6 +3156,7 @@ Tcl_DeleteCommandFromToken(
*/
cmdPtr->nsPtr->refCount++;
+
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
@@ -3519,6 +3522,7 @@ TclCleanupCommand(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
void
Tcl_CreateMathFunc(
Tcl_Interp *interp, /* Interpreter in which function is to be
@@ -3569,7 +3573,7 @@ Tcl_CreateMathFunc(
static int
OldMathFuncProc(
- ClientData clientData, /* Ponter to OldMathFuncData describing the
+ ClientData clientData, /* Pointer to OldMathFuncData describing the
* function being called */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Actual parameter count */
@@ -3850,6 +3854,7 @@ Tcl_ListMathFuncs(
return result;
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
*----------------------------------------------------------------------
@@ -4932,6 +4937,7 @@ Tcl_EvalTokensStandard(
NULL, NULL);
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -4979,6 +4985,7 @@ Tcl_EvalTokens(
Tcl_ResetResult(interp);
return resPtr;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 807a1ac..49c8c56 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -164,7 +164,7 @@ Tcl_BreakObjCmd(
*
*----------------------------------------------------------------------
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/* ARGSUSED */
int
Tcl_CaseObjCmd(
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index a206cc5..1fc2d17 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -2893,7 +2893,6 @@ StringCatCmd(
*
*----------------------------------------------------------------------
*/
-
static int
StringBytesCmd(
ClientData dummy, /* Not used. */
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index be3dc80..0c1505b 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -53,7 +53,7 @@ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp,
const char *name, const char *version,
const void *clientData);
/* 1 */
-EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp,
+EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp,
const char *name, const char *version,
int exact, void *clientDataPtr);
/* 2 */
@@ -159,8 +159,7 @@ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, double *doublePtr);
/* 36 */
EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- CONST84 char *const *tablePtr,
+ Tcl_Obj *objPtr, const char *const *tablePtr,
const char *msg, int flags, int *indexPtr);
/* 37 */
EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src,
@@ -263,7 +262,8 @@ EXTERN int Tcl_AsyncReady(void);
/* 76 */
EXTERN void Tcl_BackgroundError(Tcl_Interp *interp);
/* 77 */
-EXTERN char Tcl_Backslash(const char *src, int *readPtr);
+TCL_DEPRECATED("Use Tcl_UtfBackslash")
+char Tcl_Backslash(const char *src, int *readPtr);
/* 78 */
EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp,
const char *optionName,
@@ -280,7 +280,7 @@ EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan);
/* 82 */
EXTERN int Tcl_CommandComplete(const char *cmd);
/* 83 */
-EXTERN char * Tcl_Concat(int argc, CONST84 char *const *argv);
+EXTERN char * Tcl_Concat(int argc, const char *const *argv);
/* 84 */
EXTERN int Tcl_ConvertElement(const char *src, char *dst,
int flags);
@@ -291,7 +291,7 @@ EXTERN int Tcl_ConvertCountedElement(const char *src,
EXTERN int Tcl_CreateAlias(Tcl_Interp *slave,
const char *slaveCmd, Tcl_Interp *target,
const char *targetCmd, int argc,
- CONST84 char *const *argv);
+ const char *const *argv);
/* 87 */
EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave,
const char *slaveCmd, Tcl_Interp *target,
@@ -322,7 +322,8 @@ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc,
/* 94 */
EXTERN Tcl_Interp * Tcl_CreateInterp(void);
/* 95 */
-EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+void Tcl_CreateMathFunc(Tcl_Interp *interp,
const char *name, int numArgs,
Tcl_ValueType *argTypes, Tcl_MathProc *proc,
ClientData clientData);
@@ -412,9 +413,9 @@ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr);
/* 126 */
EXTERN int Tcl_Eof(Tcl_Channel chan);
/* 127 */
-EXTERN CONST84_RETURN char * Tcl_ErrnoId(void);
+EXTERN const char * Tcl_ErrnoId(void);
/* 128 */
-EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err);
+EXTERN const char * Tcl_ErrnoMsg(int err);
/* 129 */
EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script);
/* 130 */
@@ -469,13 +470,13 @@ EXTERN void Tcl_FreeResult(Tcl_Interp *interp);
EXTERN int Tcl_GetAlias(Tcl_Interp *interp,
const char *slaveCmd,
Tcl_Interp **targetInterpPtr,
- CONST84 char **targetCmdPtr, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char **targetCmdPtr, int *argcPtr,
+ const char ***argvPtr);
/* 149 */
EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp,
const char *slaveCmd,
Tcl_Interp **targetInterpPtr,
- CONST84 char **targetCmdPtr, int *objcPtr,
+ const char **targetCmdPtr, int *objcPtr,
Tcl_Obj ***objv);
/* 150 */
EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp,
@@ -494,7 +495,7 @@ EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan);
/* 155 */
EXTERN int Tcl_GetChannelMode(Tcl_Channel chan);
/* 156 */
-EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan);
+EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan);
/* 157 */
EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp,
Tcl_Channel chan, const char *optionName,
@@ -505,12 +506,12 @@ EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan);
EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp,
const char *cmdName, Tcl_CmdInfo *infoPtr);
/* 160 */
-EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp,
+EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command);
/* 161 */
EXTERN int Tcl_GetErrno(void);
/* 162 */
-EXTERN CONST84_RETURN char * Tcl_GetHostName(void);
+EXTERN const char * Tcl_GetHostName(void);
/* 163 */
EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp,
Tcl_Interp *slaveInterp);
@@ -546,14 +547,13 @@ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp,
/* 173 */
EXTERN Tcl_Channel Tcl_GetStdChannel(int type);
/* 174 */
-EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp);
+EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp);
/* 175 */
-EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp,
- const char *varName, int flags);
-/* 176 */
-EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp,
- const char *part1, const char *part2,
+EXTERN const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags);
+/* 176 */
+EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags);
/* 177 */
EXTERN int Tcl_GlobalEval(Tcl_Interp *interp,
const char *command);
@@ -578,7 +578,7 @@ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp);
/* 185 */
EXTERN int Tcl_IsSafe(Tcl_Interp *interp);
/* 186 */
-EXTERN char * Tcl_JoinPath(int argc, CONST84 char *const *argv,
+EXTERN char * Tcl_JoinPath(int argc, const char *const *argv,
Tcl_DString *resultPtr);
/* 187 */
EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName,
@@ -591,7 +591,7 @@ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp);
/* 191 */
EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket);
/* 192 */
-EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv);
+EXTERN char * Tcl_Merge(int argc, const char *const *argv);
/* 193 */
EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr);
/* 194 */
@@ -605,7 +605,7 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
int flags);
/* 197 */
EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
- CONST84 char **argv, int flags);
+ const char **argv, int flags);
/* 198 */
EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp,
const char *fileName, const char *modeString,
@@ -627,7 +627,7 @@ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value,
/* 203 */
EXTERN int Tcl_PutEnv(const char *assignment);
/* 204 */
-EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp);
+EXTERN const char * Tcl_PosixError(Tcl_Interp *interp);
/* 205 */
EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr,
Tcl_QueuePosition position);
@@ -657,8 +657,7 @@ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
const char *pattern);
/* 215 */
EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
- CONST84 char **startPtr,
- CONST84 char **endPtr);
+ const char **startPtr, const char **endPtr);
/* 216 */
EXTERN void Tcl_Release(ClientData clientData);
/* 217 */
@@ -714,26 +713,25 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp,
/* 236 */
EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type);
/* 237 */
-EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp,
- const char *varName, const char *newValue,
- int flags);
-/* 238 */
-EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp,
- const char *part1, const char *part2,
+EXTERN const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags);
+/* 238 */
+EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, const char *newValue,
+ int flags);
/* 239 */
-EXTERN CONST84_RETURN char * Tcl_SignalId(int sig);
+EXTERN const char * Tcl_SignalId(int sig);
/* 240 */
-EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig);
+EXTERN const char * Tcl_SignalMsg(int sig);
/* 241 */
EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp);
/* 242 */
EXTERN int Tcl_SplitList(Tcl_Interp *interp,
const char *listStr, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char ***argvPtr);
/* 243 */
EXTERN void Tcl_SplitPath(const char *path, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char ***argvPtr);
/* 244 */
EXTERN void Tcl_StaticPackage(Tcl_Interp *interp,
const char *pkgName,
@@ -824,23 +822,21 @@ void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
/* 269 */
EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr);
/* 270 */
-EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp,
- const char *start, CONST84 char **termPtr);
+EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start,
+ const char **termPtr);
/* 271 */
-EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp,
- const char *name, const char *version,
- int exact);
+EXTERN const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+ const char *version, int exact);
/* 272 */
-EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp,
+EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version,
int exact, void *clientDataPtr);
/* 273 */
EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
const char *version);
/* 274 */
-EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp,
- const char *name, const char *version,
- int exact);
+EXTERN const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
+ const char *version, int exact);
/* 275 */
TCL_DEPRECATED("see TIP #422")
void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
@@ -917,7 +913,7 @@ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void);
/* 301 */
EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name);
/* 302 */
-EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding);
+EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding);
/* 303 */
EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp);
/* 304 */
@@ -976,20 +972,20 @@ EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch);
/* 324 */
EXTERN int Tcl_UniCharToUtf(int ch, char *buf);
/* 325 */
-EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index);
+EXTERN const char * Tcl_UtfAtIndex(const char *src, int index);
/* 326 */
EXTERN int Tcl_UtfCharComplete(const char *src, int length);
/* 327 */
EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr,
char *dst);
/* 328 */
-EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(const char *src, int ch);
+EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch);
/* 329 */
-EXTERN CONST84_RETURN char * Tcl_UtfFindLast(const char *src, int ch);
+EXTERN const char * Tcl_UtfFindLast(const char *src, int ch);
/* 330 */
-EXTERN CONST84_RETURN char * Tcl_UtfNext(const char *src);
+EXTERN const char * Tcl_UtfNext(const char *src);
/* 331 */
-EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start);
+EXTERN const char * Tcl_UtfPrev(const char *src, const char *start);
/* 332 */
EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp,
Tcl_Encoding encoding, const char *src,
@@ -1017,9 +1013,11 @@ EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr);
/* 340 */
EXTERN char * Tcl_GetString(Tcl_Obj *objPtr);
/* 341 */
-EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void);
+TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath")
+const char * Tcl_GetDefaultEncodingDir(void);
/* 342 */
-EXTERN void Tcl_SetDefaultEncodingDir(const char *path);
+TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath")
+void Tcl_SetDefaultEncodingDir(const char *path);
/* 343 */
EXTERN void Tcl_AlertNotifier(ClientData clientData);
/* 344 */
@@ -1054,7 +1052,8 @@ EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length,
EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp,
Tcl_Obj *patObj, int flags);
/* 357 */
-EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_EvalTokensStandard")
+Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count);
/* 358 */
EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr);
@@ -1066,7 +1065,7 @@ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp,
EXTERN int Tcl_ParseBraces(Tcl_Interp *interp,
const char *start, int numBytes,
Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr);
+ const char **termPtr);
/* 361 */
EXTERN int Tcl_ParseCommand(Tcl_Interp *interp,
const char *start, int numBytes, int nested,
@@ -1078,7 +1077,7 @@ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start,
EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp,
const char *start, int numBytes,
Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr);
+ const char **termPtr);
/* 364 */
EXTERN int Tcl_ParseVarName(Tcl_Interp *interp,
const char *start, int numBytes,
@@ -1168,8 +1167,7 @@ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan);
/* 397 */
EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan);
/* 398 */
-EXTERN CONST84_RETURN char * Tcl_ChannelName(
- const Tcl_ChannelType *chanTypePtr);
+EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr);
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr);
@@ -1275,13 +1273,15 @@ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel);
EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr,
int *lengthPtr);
/* 435 */
-EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+int Tcl_GetMathFuncInfo(Tcl_Interp *interp,
const char *name, int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr,
ClientData *clientDataPtr);
/* 436 */
-EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp,
const char *pattern);
/* 437 */
EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -1850,7 +1850,7 @@ typedef struct TclStubs {
const TclStubHooks *hooks;
int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */
- CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
+ const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */
char * (*tcl_Alloc) (unsigned int size); /* 3 */
void (*tcl_Free) (char *ptr); /* 4 */
@@ -1901,7 +1901,7 @@ typedef struct TclStubs {
unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */
int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */
int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */
- int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
+ int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */
int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */
int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */
@@ -1942,16 +1942,16 @@ typedef struct TclStubs {
void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */
int (*tcl_AsyncReady) (void); /* 75 */
void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */
- char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */
+ TCL_DEPRECATED_API("Use Tcl_UtfBackslash") char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */
int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */
void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */
void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */
int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */
int (*tcl_CommandComplete) (const char *cmd); /* 82 */
- char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */
+ char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */
int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */
- int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */
+ int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */
int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */
Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */
void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */
@@ -1960,7 +1960,7 @@ typedef struct TclStubs {
void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */
void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */
Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */
- void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */
+ TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */
Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */
Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */
Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */
@@ -1992,8 +1992,8 @@ typedef struct TclStubs {
void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */
void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */
int (*tcl_Eof) (Tcl_Channel chan); /* 126 */
- CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */
- CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */
+ const char * (*tcl_ErrnoId) (void); /* 127 */
+ const char * (*tcl_ErrnoMsg) (int err); /* 128 */
int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */
int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */
int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
@@ -2013,21 +2013,21 @@ typedef struct TclStubs {
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
- int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */
- int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
+ int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */
+ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */
Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */
int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */
int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */
ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */
int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */
- CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
+ const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */
CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */
int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */
- CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
+ const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
int (*tcl_GetErrno) (void); /* 161 */
- CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */
+ const char * (*tcl_GetHostName) (void); /* 162 */
int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */
Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */
const char * (*tcl_GetNameOfExecutable) (void); /* 165 */
@@ -2047,9 +2047,9 @@ typedef struct TclStubs {
int (*tcl_GetServiceMode) (void); /* 171 */
Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
- CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
- CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
- CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
+ const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
+ const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
+ const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */
int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */
int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */
@@ -2059,25 +2059,25 @@ typedef struct TclStubs {
int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */
int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */
int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */
- char * (*tcl_JoinPath) (int argc, CONST84 char *const *argv, Tcl_DString *resultPtr); /* 186 */
+ char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */
int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */
void (*reserved188)(void);
Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */
int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */
Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */
- char * (*tcl_Merge) (int argc, CONST84 char *const *argv); /* 192 */
+ char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */
Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */
void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */
Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */
Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */
- Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, CONST84 char **argv, int flags); /* 197 */
+ Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, const char **argv, int flags); /* 197 */
Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */
Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */
Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */
void (*tcl_Preserve) (ClientData data); /* 201 */
void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */
int (*tcl_PutEnv) (const char *assignment); /* 203 */
- CONST84_RETURN char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
+ const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */
int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */
void (*tcl_ReapDetachedProcs) (void); /* 207 */
@@ -2088,7 +2088,7 @@ typedef struct TclStubs {
Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */
int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */
int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */
- void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */
+ void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, const char **startPtr, const 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 */
@@ -2110,13 +2110,13 @@ typedef struct TclStubs {
void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */
void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */
void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */
- CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
- CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
- CONST84_RETURN char * (*tcl_SignalId) (int sig); /* 239 */
- CONST84_RETURN char * (*tcl_SignalMsg) (int sig); /* 240 */
+ const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
+ const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
+ const char * (*tcl_SignalId) (int sig); /* 239 */
+ const char * (*tcl_SignalMsg) (int sig); /* 240 */
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 */
+ int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */
+ void (*tcl_SplitPath) (const char *path, int *argcPtr, const 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 */
TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
@@ -2143,11 +2143,11 @@ typedef struct TclStubs {
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 */
+ const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */
+ const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
+ const 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 */
+ const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
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 */
@@ -2175,7 +2175,7 @@ typedef struct TclStubs {
void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */
Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */
Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */
- CONST84_RETURN char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
+ const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */
int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr); /* 304 */
void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */
@@ -2198,13 +2198,13 @@ typedef struct TclStubs {
Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */
Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */
int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
- CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
+ const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */
int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */
- CONST84_RETURN char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
- CONST84_RETURN char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
- CONST84_RETURN char * (*tcl_UtfNext) (const char *src); /* 330 */
- CONST84_RETURN char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */
+ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
+ const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
+ const char * (*tcl_UtfNext) (const char *src); /* 330 */
+ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */
int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */
char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */
int (*tcl_UtfToLower) (char *src); /* 334 */
@@ -2214,8 +2214,8 @@ typedef struct TclStubs {
int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */
int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */
char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */
- CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */
- void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */
+ TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */
+ TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */
void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */
void (*tcl_ServiceModeHook) (int mode); /* 344 */
int (*tcl_UniCharIsAlnum) (int ch); /* 345 */
@@ -2230,13 +2230,13 @@ typedef struct TclStubs {
char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */
Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */
Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */
- Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */
+ TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */
void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */
void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */
- int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */
+ int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */
int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */
int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */
- int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 363 */
+ int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */
int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */
char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */
int (*tcl_Chdir) (const char *dirName); /* 366 */
@@ -2271,7 +2271,7 @@ typedef struct TclStubs {
int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */
int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */
- CONST84_RETURN char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
+ const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */
Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */
Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */
@@ -2308,8 +2308,8 @@ typedef struct TclStubs {
int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */
Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */
Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */
- int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */
- Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */
+ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */
+ TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */
Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */
int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */
int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 46db12c..3d892b7 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -693,6 +693,7 @@ TclFinalizeEncodingSubsystem(void)
*-------------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
const char *
Tcl_GetDefaultEncodingDir(void)
{
@@ -736,6 +737,7 @@ Tcl_SetDefaultEncodingDir(
Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory);
Tcl_SetEncodingSearchPath(searchPath);
}
+#endif
/*
*-------------------------------------------------------------------------
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 49fd2ae..93cf983 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1057,7 +1057,6 @@ TclInitSubsystems(void)
* mutexes. */
TclInitIOSubsystem(); /* Inits a tsd key (noop). */
TclInitEncodingSubsystem(); /* Process wide encoding init. */
- TclpSetInterfaces();
TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
subsystemsInitialized = 1;
}
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 6e8bd09..87bf415 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -137,7 +137,7 @@ Tcl_PutsObjCmd(
chanObjPtr = objv[2];
string = objv[3];
break;
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
} else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) {
/*
* The code below provides backwards compatibility with an old
@@ -439,7 +439,7 @@ Tcl_ReadObjCmd(
if (i < objc) {
if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK)
|| (toRead < 0)) {
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
@@ -454,7 +454,7 @@ Tcl_ReadObjCmd(
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
}
newline = 1;
#endif
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 8fb3aa8..144bab0 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -830,15 +830,6 @@ TclResetFilesystem(void)
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
-
-#ifdef _WIN32
- /*
- * Cleans up the win32 API filesystem proc lookup table. This must happen
- * very late in finalization so that deleting of copied dlls can occur.
- */
-
- TclWinResetInterfaces();
-#endif
}
/*
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 175ea9c..2c18510 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -187,7 +187,7 @@ declare 42 {
}
# Removed in 8.5a2:
#declare 43 {
-# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
+# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv,
# int flags)
#}
declare 44 {
@@ -222,12 +222,12 @@ declare 51 {
}
# Removed in 8.5a2:
#declare 52 {
-# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
+# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv,
# int flags)
#}
declare 53 {
int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
- int argc, CONST84 char **argv)
+ int argc, const char **argv)
}
declare 54 {
int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
@@ -548,7 +548,7 @@ declare 133 {deprecated {}} {
# int TclpChdir(const char *dirName)
#}
declare 138 {
- CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
+ const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
#declare 139 {
# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
@@ -560,7 +560,7 @@ declare 138 {
#}
# This is used by TclX, but should otherwise be considered private
declare 141 {
- CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
+ const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2ba0493..a3bd8ba 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -160,13 +160,13 @@ typedef struct Tcl_ResolvedVarInfo {
} Tcl_ResolvedVarInfo;
typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp,
- CONST84 char *name, int length, Tcl_Namespace *context,
+ const char *name, int length, Tcl_Namespace *context,
Tcl_ResolvedVarInfo **rPtr);
-typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name,
+typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Var *rPtr);
-typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name,
+typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Command *rPtr);
typedef struct Tcl_ResolverInfo {
@@ -426,7 +426,7 @@ struct NamespacePathEntry {
*/
typedef struct EnsembleConfig {
- Namespace *nsPtr; /* The namspace backing this ensemble up. */
+ Namespace *nsPtr; /* The namespace backing this ensemble up. */
Tcl_Command token; /* The token for the command that provides
* ensemble support for the namespace, or NULL
* if the command has been deleted (or never
@@ -1826,7 +1826,7 @@ typedef struct Interp {
* unused space in interp was repurposed for
* pluggable bytecode optimizers. The core
* contains one optimizer, which can be
- * selectively overriden by extensions. */
+ * selectively overridden by extensions. */
} extra;
/*
@@ -1862,7 +1862,7 @@ typedef struct Interp {
* See Tcl_AppendResult code for details.
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
char *appendResult; /* Storage space for results generated by
* Tcl_AppendResult. Ckalloc-ed. NULL means
* not yet allocated. */
@@ -1936,11 +1936,13 @@ typedef struct Interp {
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
-#ifndef TCL_NO_DEPRECATED
- char resultSpace[TCL_RESULT_SIZE+1];
+#if TCL_MAJOR_VERSION < 9
+# if !defined(TCL_NO_DEPRECATED)
+ char resultSpace[TCL_DSTRING_STATIC_SIZE+1];
/* Static space holding small results. */
-#else
- char resultSpaceDontUse[TCL_RESULT_SIZE+1];
+# else
+ char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1];
+# endif
#endif
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
@@ -2251,7 +2253,7 @@ typedef struct Interp {
* use the rand() or srand() functions.
* SAFE_INTERP: Non zero means that the current interp is a safe
* interp (i.e. it has only the safe commands installed,
- * less priviledge than a regular interp).
+ * less privilege than a regular interp).
* INTERP_DEBUG_FRAME: Used for switching on various extra interpreter
* debug/info mechanisms (e.g. info frame eval/uplevel
* tracing) which are performance intensive.
@@ -2392,7 +2394,7 @@ typedef struct List {
* be ignored if there is no string rep at
* all.*/
Tcl_Obj *elements; /* First list element; the struct is grown to
- * accomodate all elements. */
+ * accommodate all elements. */
} List;
#define LIST_MAX \
@@ -2514,13 +2516,13 @@ typedef struct List {
* tip of the path, so duplication of shared objects should be done along the
* way.
*
- * DICT_PATH_EXISTS indicates that we are performing an existance test and a
+ * DICT_PATH_EXISTS indicates that we are performing an existence test and a
* lookup failure should therefore not be an error. If (and only if) this flag
* is set, TclTraceDictPath() will return the special value
* DICT_PATH_NON_EXISTENT if the path is not traceable.
*
* DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set)
- * indicates that we are to create non-existant dictionaries on the path.
+ * indicates that we are to create non-existent dictionaries on the path.
*/
#define DICT_PATH_READ 0
@@ -3157,7 +3159,6 @@ MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_PathPart portion);
MODULE_SCOPE char * TclpReadlink(const char *fileName,
Tcl_DString *linkPtr);
-MODULE_SCOPE void TclpSetInterfaces(void);
MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr);
MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr,
@@ -3267,7 +3268,7 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index bc8f7b8..f223225 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -174,7 +174,7 @@ EXTERN int TclInterpInit(Tcl_Interp *interp);
/* 53 */
EXTERN int TclInvokeObjectCommand(ClientData clientData,
Tcl_Interp *interp, int argc,
- CONST84 char **argv);
+ const char **argv);
/* 54 */
EXTERN int TclInvokeStringCommand(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -361,13 +361,11 @@ struct tm * TclpGetDate(const time_t *time, int useGMT);
/* Slot 136 is reserved */
/* Slot 137 is reserved */
/* 138 */
-EXTERN CONST84_RETURN char * TclGetEnv(const char *name,
- Tcl_DString *valuePtr);
+EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr);
/* Slot 139 is reserved */
/* Slot 140 is reserved */
/* 141 */
-EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp,
- Tcl_DString *cwdPtr);
+EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
/* 142 */
EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr, CompileHookProc *hookProc,
@@ -709,7 +707,7 @@ typedef struct TclIntStubs {
void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */
int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */
void (*reserved52)(void);
- int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv); /* 53 */
+ int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */
int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */
Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */
void (*reserved56)(void);
@@ -794,10 +792,10 @@ typedef struct TclIntStubs {
void (*reserved135)(void);
void (*reserved136)(void);
void (*reserved137)(void);
- CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
+ const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
void (*reserved139)(void);
void (*reserved140)(void);
- CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
+ const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */
int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 1222cee..0e160ca 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -555,12 +555,18 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
# undef TclWinGetServByName
# undef TclWinGetSockOpt
# undef TclWinSetSockOpt
-# define TclWinNToHS ntohs
-# define TclWinGetServByName getservbyname
-# define TclWinGetSockOpt getsockopt
-# define TclWinSetSockOpt setsockopt
# undef TclWinGetPlatformId
-# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */
+# undef TclWinResetInterfaces
+# undef TclWinSetInterfaces
+# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+# define TclWinNToHS ntohs
+# define TclWinGetServByName getservbyname
+# define TclWinGetSockOpt getsockopt
+# define TclWinSetSockOpt setsockopt
+# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */
+# define TclWinResetInterfaces() /* nop */
+# define TclWinSetInterfaces(dummy) /* nop */
+# endif /* TCL_NO_DEPRECATED */
#else
# undef TclpGetPid
# define TclpGetPid(pid) ((unsigned long) (pid))
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 84380e0..39e3fb2 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -60,8 +60,6 @@ static const struct {
static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj);
static Object * AllocObject(Tcl_Interp *interp, const char *nameStr,
Namespace *nsPtr, const char *nsNameStr);
-static void ClearMixins(Class *clsPtr);
-static void ClearSuperclasses(Class *clsPtr);
static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
Method *mPtr, Tcl_Obj *namePtr,
Method **newMPtrPtr);
@@ -73,6 +71,9 @@ static void DeletedHelpersNamespace(ClientData clientData);
static Tcl_NRPostProc FinalizeAlloc;
static Tcl_NRPostProc FinalizeNext;
static Tcl_NRPostProc FinalizeObjectCall;
+static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr);
+static void InitClassSystemRoots(Tcl_Interp *interp,
+ Foundation *fPtr);
static int InitFoundation(Tcl_Interp *interp);
static void KillFoundation(ClientData clientData,
Tcl_Interp *interp);
@@ -82,6 +83,9 @@ static void ObjectRenamedTrace(ClientData clientData,
Tcl_Interp *interp, const char *oldName,
const char *newName, int flags);
static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
+static void DeleteDescendants(Tcl_Interp *interp,Object *oPtr);
+static inline void RemoveClass(Class **list, int num, int idx);
+static inline void RemoveObject(Object **list, int num, int idx);
static inline void SquelchCachedName(Object *oPtr);
static int PublicObjectCmd(ClientData clientData,
@@ -228,10 +232,52 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
* ROOT_CLASS respectively.
*/
-#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL)
+#define Deleted(oPtr) ((oPtr)->flags & OBJECT_DELETED)
#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
+
+#define RemoveItem(type, lst, i) \
+ do { \
+ Remove ## type ((lst).list, (lst).num, i); \
+ (lst).num--; \
+ } while (0)
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * RemoveClass, RemoveObject --
+ *
+ * Helpers for the RemoveItem macro for deleting a class or object from a
+ * list. Setting the "empty" location to NULL makes debugging a little
+ * easier.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+RemoveClass(
+ Class **list,
+ int num,
+ int idx)
+{
+ for (; idx < num - 1; idx++) {
+ list[idx] = list[idx + 1];
+ }
+ list[idx] = NULL;
+}
+
+static inline void
+RemoveObject(
+ Object **list,
+ int num,
+ int idx)
+{
+ for (; idx < num - 1; idx++) {
+ list[idx] = list[idx + 1];
+ }
+ list[idx] = NULL;
+}
/*
* ----------------------------------------------------------------------
@@ -375,28 +421,10 @@ InitFoundation(
Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
/*
- * Create the objects at the core of the object system. These need to be
- * spliced manually.
+ * Create the special objects at the core of the object system.
*/
- fPtr->objectCls = AllocClass(interp,
- AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
- fPtr->classCls = AllocClass(interp,
- AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
- fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
- fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
- fPtr->objectCls->flags |= ROOT_OBJECT;
- fPtr->objectCls->superclasses.num = 0;
- ckfree(fPtr->objectCls->superclasses.list);
- fPtr->objectCls->superclasses.list = NULL;
- fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
- fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
- fPtr->classCls->flags |= ROOT_CLASS;
- TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
- TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
- TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
- AddRef(fPtr->objectCls->thisPtr);
- AddRef(fPtr->objectCls);
+ InitClassSystemRoots(interp, fPtr);
/*
* Basic method declarations for the core classes.
@@ -463,6 +491,88 @@ InitFoundation(
}
return Tcl_EvalEx(interp, slotScript, -1, 0);
}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitClassSystemRoots --
+ *
+ * Creates the objects at the core of the object system. These need to be
+ * spliced manually.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+InitClassSystemRoots(
+ Tcl_Interp *interp,
+ Foundation *fPtr)
+{
+ Class fakeCls;
+ Object fakeObject;
+
+ /*
+ * Stand up a phony class for bootstrapping.
+ */
+
+ fPtr->objectCls = &fakeCls;
+
+ /*
+ * Referenced in AllocClass to increment the refCount.
+ */
+
+ fakeCls.thisPtr = &fakeObject;
+
+ fPtr->objectCls = AllocClass(interp,
+ AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
+ fPtr->classCls = AllocClass(interp,
+ AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
+
+ /*
+ * Rewire bootstrapped objects.
+ */
+
+ fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
+ fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+
+ AddRef(fPtr->objectCls->thisPtr);
+ AddRef(fPtr->classCls->thisPtr);
+ AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr);
+ AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr);
+
+ /*
+ * Special initialization for the primordial objects.
+ */
+
+ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+ fPtr->objectCls->flags |= ROOT_OBJECT;
+
+ /*
+ * This is why it is unnecessary in this routine to make up for the
+ * incremented reference count of fPtr->objectCls that was sallwed by
+ * fakeObject.
+ */
+
+ fPtr->objectCls->superclasses.num = 0;
+ ckfree(fPtr->objectCls->superclasses.list);
+ fPtr->objectCls->superclasses.list = NULL;
+
+ fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
+ fPtr->classCls->flags |= ROOT_CLASS;
+
+ /*
+ * Standard initialization for new Objects.
+ */
+
+ TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
+ TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
+ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
+
+ /*
+ * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING.
+ * Everything else is careful to prohibit looping.
+ */
+}
/*
* ----------------------------------------------------------------------
@@ -522,8 +632,6 @@ KillFoundation(
{
Foundation *fPtr = GetFoundation(interp);
- DelRef(fPtr->objectCls->thisPtr);
- DelRef(fPtr->objectCls);
TclDecrRefCount(fPtr->unknownMethodNameObj);
TclDecrRefCount(fPtr->constructorName);
TclDecrRefCount(fPtr->destructorName);
@@ -538,8 +646,11 @@ KillFoundation(
* AllocObject --
*
* Allocate an object of basic type. Does not splice the object into its
- * class's instance list. The caller must set the classPtr on the object,
- * either to a class or to NULL.
+ * class's instance list. The caller must set the classPtr on the object
+ * to either a class or NULL, call TclOOAddToInstances to add the object
+ * to the class's instance list, and if the object itself is a class, use
+ * call TclOOAddToSubclasses() to add it to the right class's list of
+ * subclasses.
*
* ----------------------------------------------------------------------
*/
@@ -552,8 +663,8 @@ AllocObject(
* if the OO system should pick the object
* name itself (equal to the namespace
* name). */
- Namespace *nsPtr, /* The namespace to create the object in,
- or NULL if *nameStr is NULL */
+ Namespace *nsPtr, /* The namespace to create the object in, or
+ * NULL if *nameStr is NULL */
const char *nsNameStr) /* The name of the namespace to create, or
* NULL if the OO system should pick a unique
* name itself. If this is non-NULL but names
@@ -564,7 +675,7 @@ AllocObject(
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
- int creationEpoch, ignored;
+ int creationEpoch;
oPtr = ckalloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
@@ -641,9 +752,15 @@ AllocObject(
*/
oPtr->fPtr = fPtr;
- oPtr->selfCls = fPtr->objectCls;
oPtr->creationEpoch = creationEpoch;
- oPtr->refCount = 1;
+
+ /*
+ * An object starts life with a refCount of 2 to mark the two stages of
+ * destruction it occur: A call to ObjectRenamedTrace(), and a call to
+ * ObjectNamespaceDeleted().
+ */
+
+ oPtr->refCount = 2;
oPtr->flags = USE_CLASS_CACHE;
/*
@@ -655,6 +772,10 @@ AllocObject(
if (!nameStr) {
nameStr = oPtr->namespacePtr->name;
nsPtr = (Namespace *)oPtr->namespacePtr;
+ if (nsPtr->parentPtr != NULL) {
+ nsPtr = nsPtr->parentPtr;
+ }
+
}
oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
(Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
@@ -673,26 +794,8 @@ AllocObject(
tracePtr->nextPtr = NULL;
tracePtr->refCount = 1;
- /*
- * Access the namespace command table directly when creating "my" to avoid
- * a bottleneck in string manipulation. Another abstraction-buster.
- */
-
- cmdPtr = ckalloc(sizeof(Command));
- memset(cmdPtr, 0, sizeof(Command));
- cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr;
- cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my",
- &ignored);
- cmdPtr->refCount = 1;
- cmdPtr->objProc = PrivateObjectCmd;
- cmdPtr->deleteProc = MyDeleted;
- cmdPtr->objClientData = cmdPtr->deleteData = oPtr;
- cmdPtr->proc = TclInvokeObjectCommand;
- cmdPtr->clientData = cmdPtr;
- cmdPtr->nreProc = PrivateNRObjectCmd;
- Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr);
- oPtr->myCommand = (Tcl_Command) cmdPtr;
-
+ oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
+ PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
return oPtr;
}
@@ -762,6 +865,7 @@ ObjectRenamedTrace(
int flags) /* Why was the object deleted? */
{
Object *oPtr = clientData;
+
/*
* If this is a rename and not a delete of the object, we just flush the
* cache of the object name.
@@ -774,95 +878,84 @@ ObjectRenamedTrace(
/*
* The namespace is only deleted if it hasn't already been deleted. [Bug
- * 2950259]. If the namespace has already been deleted, then
- * ObjectNamespaceDeleted() has already cleaned up this command.
+ * 2950259].
*/
- if (oPtr->namespacePtr == NULL) {
- /*
- * ObjectNamespaceDeleted() has already done all the cleanup, but
- * detected that the command was in the process of being deleted, and
- * left the pointer allocated for us.
- */
- DelRef(oPtr);
- } else {
- if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc == NULL) {
- /*
- * ObjectNamespaceDeleted() called us, and still has some work to
- * do, so we leave the pointer allocated for it to finish, and then
- * it will deallocate the pointer.
- */
- } else {
- Tcl_DeleteNamespace(oPtr->namespacePtr);
- /*
- * ObjectNamespaceDeleted() doesn't know it was us that just
- * called, so it left the pointer allocated.
- */
- DelRef(oPtr);
- }
+ if (!Deleted(oPtr)) {
+ Tcl_DeleteNamespace(oPtr->namespacePtr);
}
+ oPtr->command = NULL;
+ TclOODecrRefCount(oPtr);
return;
}
/*
* ----------------------------------------------------------------------
*
- * ClearMixins, ClearSuperclasses --
+ * DeleteDescendants, ReleaseClassContents --
*
- * Utility functions for correctly clearing the list of mixins or
- * superclasses of a class. Will ckfree() the list storage.
+ * Tear down the special class data structure, including deleting all
+ * dependent classes and objects.
*
* ----------------------------------------------------------------------
*/
static void
-ClearMixins(
- Class *clsPtr)
+DeleteDescendants(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Object *oPtr) /* The object representing the class. */
{
+ Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr;
+ Object *instancePtr;
int i;
- Class *mixinPtr;
- if (clsPtr->mixins.num == 0) {
- return;
- }
+ /*
+ * Squelch classes that this class has been mixed into.
+ */
+
+ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
+ /*
+ * This condition also covers the case where mixinSubclassPtr ==
+ * clsPtr
+ */
- FOREACH(mixinPtr, clsPtr->mixins) {
- TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
+ if (!Deleted(mixinSubclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp,
+ mixinSubclassPtr->thisPtr->command);
+ }
+ i -= TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
+ TclOODecrRefCount(mixinSubclassPtr->thisPtr);
}
- ckfree(clsPtr->mixins.list);
- clsPtr->mixins.list = NULL;
- clsPtr->mixins.num = 0;
-}
-static void
-ClearSuperclasses(
- Class *clsPtr)
-{
- int i;
- Class *superPtr;
+ /*
+ * Squelch subclasses of this class.
+ */
- if (clsPtr->superclasses.num == 0) {
- return;
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) {
+ Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
+ }
+ i -= TclOORemoveFromSubclasses(subclassPtr, clsPtr);
+ TclOODecrRefCount(subclassPtr->thisPtr);
}
- FOREACH(superPtr, clsPtr->superclasses) {
- TclOORemoveFromSubclasses(clsPtr, superPtr);
+ /*
+ * Squelch instances of this class (includes objects we're mixed into).
+ */
+
+ if (!IsRootClass(oPtr)) {
+ FOREACH(instancePtr, clsPtr->instances) {
+ /*
+ * This condition also covers the case where instancePtr == oPtr
+ */
+
+ if (!Deleted(instancePtr) && !IsRoot(instancePtr)) {
+ Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+ }
+ i -= TclOORemoveFromInstances(instancePtr, clsPtr);
+ }
}
- ckfree(clsPtr->superclasses.list);
- clsPtr->superclasses.list = NULL;
- clsPtr->superclasses.num = 0;
}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ReleaseClassContents --
- *
- * Tear down the special class data structure, including deleting all
- * dependent classes and objects.
- *
- * ----------------------------------------------------------------------
- */
static void
ReleaseClassContents(
@@ -871,8 +964,7 @@ ReleaseClassContents(
{
FOREACH_HASH_DECLS;
int i;
- Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
- Object *instancePtr;
+ Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
Tcl_Obj *variableObj;
@@ -895,132 +987,6 @@ ReleaseClassContents(
}
/*
- * Lock a number of dependent objects until we've stopped putting our
- * fingers in them.
- */
-
- FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
- if (mixinSubclassPtr != NULL) {
- AddRef(mixinSubclassPtr);
- AddRef(mixinSubclassPtr->thisPtr);
- }
- }
- FOREACH(subclassPtr, clsPtr->subclasses) {
- if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
- AddRef(subclassPtr);
- AddRef(subclassPtr->thisPtr);
- }
- }
- if (!IsRootClass(oPtr)) {
- FOREACH(instancePtr, clsPtr->instances) {
- if (instancePtr != oPtr) {
- int j;
- if (instancePtr->selfCls == clsPtr) {
- instancePtr->flags |= CLASS_GONE;
- }
- for(j=0 ; j<instancePtr->mixins.num ; j++) {
- Class *mixin = instancePtr->mixins.list[j];
- Class *nextMixin = NULL;
- if (mixin == clsPtr) {
- if (j < instancePtr->mixins.num - 1) {
- nextMixin = instancePtr->mixins.list[j+1];
- }
- if (j == 0) {
- instancePtr->mixins.num = 0;
- instancePtr->mixins.list = NULL;
- } else {
- instancePtr->mixins.list[j-1] = nextMixin;
- }
- instancePtr->mixins.num -= 1;
- }
- }
- if (instancePtr != NULL && !IsRoot(instancePtr)) {
- AddRef(instancePtr);
- }
- }
- }
- }
-
- /*
- * Squelch classes that this class has been mixed into.
- */
-
- FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
- if (mixinSubclassPtr != clsPtr) {
- if (!Deleted(mixinSubclassPtr->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp,
- mixinSubclassPtr->thisPtr->command);
- }
- ClearMixins(mixinSubclassPtr);
- DelRef(mixinSubclassPtr->thisPtr);
- DelRef(mixinSubclassPtr);
- }
- }
- if (clsPtr->mixinSubs.list != NULL) {
- ckfree(clsPtr->mixinSubs.list);
- clsPtr->mixinSubs.list = NULL;
- clsPtr->mixinSubs.num = 0;
- }
-
- /*
- * Squelch subclasses of this class.
- */
-
- FOREACH(subclassPtr, clsPtr->subclasses) {
- if (IsRoot(subclassPtr)) {
- continue;
- }
- if (!Deleted(subclassPtr->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
- }
- ClearSuperclasses(subclassPtr);
- DelRef(subclassPtr->thisPtr);
- DelRef(subclassPtr);
- }
- if (clsPtr->subclasses.list != NULL) {
- ckfree(clsPtr->subclasses.list);
- clsPtr->subclasses.list = NULL;
- clsPtr->subclasses.num = 0;
- }
-
- /*
- * Squelch instances of this class (includes objects we're mixed into).
- */
-
- if (!IsRootClass(oPtr)) {
- FOREACH(instancePtr, clsPtr->instances) {
- if (instancePtr != oPtr) {
- if (instancePtr == NULL || IsRoot(instancePtr)) {
- continue;
- }
- if (!Deleted(instancePtr)) {
- Tcl_DeleteCommandFromToken(interp, instancePtr->command);
- /*
- * Tcl_DeleteCommandFromToken() may have done to whole
- * job for us. Roll back and check again.
- */
- i--;
- continue;
- }
- DelRef(instancePtr);
- }
- }
- }
- if (clsPtr->instances.list != NULL) {
- ckfree(clsPtr->instances.list);
- clsPtr->instances.list = NULL;
- clsPtr->instances.num = 0;
- }
-
- /*
- * Special: We delete these after everything else.
- */
-
- if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
- }
-
- /*
* Squelch method implementation chain caches.
*/
@@ -1073,8 +1039,12 @@ ReleaseClassContents(
clsPtr->metadataPtr = NULL;
}
- ClearMixins(clsPtr);
- ClearSuperclasses(clsPtr);
+ FOREACH(tmpClsPtr, clsPtr->mixins) {
+ TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
+ }
+ FOREACH(tmpClsPtr, clsPtr->superclasses) {
+ TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
+ }
FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
TclOODelMethodRef(mPtr);
@@ -1090,12 +1060,9 @@ ReleaseClassContents(
ckfree(clsPtr->variables.list);
}
- /* Tell oPtr that it's class is gone so that it doesn't try to remove
- * itself from it's classe's list of instances
- */
- oPtr->flags |= CLASS_GONE;
- DelRef(clsPtr);
-
+ if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
+ }
}
/*
@@ -1123,13 +1090,29 @@ ObjectNamespaceDeleted(
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
Tcl_Interp *interp = oPtr->fPtr->interp;
- int finished = 0, i;
+ int i;
+
+ if (Deleted(oPtr)) {
+ /*
+ * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this
+ * guard could be removed.
+ */
+ return;
+ }
- AddRef(fPtr->classCls);
- AddRef(fPtr->objectCls);
- AddRef(fPtr->classCls->thisPtr);
- AddRef(fPtr->objectCls->thisPtr);
+ /*
+ * One rule for the teardown routines is that if an object is in the
+ * process of being deleted, nothing else may modify its bookeeping
+ * records. This is the flag that
+ */
+
+ oPtr->flags |= OBJECT_DELETED;
+
+ /* Let the dominoes fall */
+ if (oPtr->classPtr) {
+ DeleteDescendants(interp, oPtr);
+ }
/*
* We do not run destructors on the core class objects when the
@@ -1138,14 +1121,14 @@ ObjectNamespaceDeleted(
* of it have gone. [Bug 2949397]
*/
- if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
+ if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
CallContext *contextPtr =
TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
int result;
Tcl_InterpState state;
-
oPtr->flags |= DESTRUCTOR_CALLED;
+
if (contextPtr != NULL) {
contextPtr->callPtr->flags |= DESTRUCTOR;
contextPtr->skip = 0;
@@ -1167,7 +1150,7 @@ ObjectNamespaceDeleted(
* points into freed memory.
*/
- if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) {
+ if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) {
/*
* Something has already started the command deletion process. We can
* go ahead and clean up the the namespace,
@@ -1177,10 +1160,9 @@ ObjectNamespaceDeleted(
* The namespace must have been deleted directly. Delete the command
* as well.
*/
+
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
- finished = 1;
}
- oPtr->command = NULL;
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
@@ -1191,14 +1173,14 @@ ObjectNamespaceDeleted(
* methods on the object.
*/
- if (!IsRootObject(oPtr) && !(oPtr->flags & CLASS_GONE)) {
- TclOORemoveFromInstances(oPtr, oPtr->selfCls);
- }
+ /*
+ * TODO: Should this be protected with a * !IsRoot() condition?
+ */
+
+ TclOORemoveFromInstances(oPtr, oPtr->selfCls);
FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr && mixinPtr != oPtr->classPtr) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
- }
+ i -= TclOORemoveFromInstances(oPtr, mixinPtr);
}
if (i) {
ckfree(oPtr->mixins.list);
@@ -1245,21 +1227,19 @@ ObjectNamespaceDeleted(
}
/*
- * Because an object can be a class that is an instance of itself, the
- * A class object's class structure should only be cleaned after most of
- * the cleanup on the object is done.
- */
-
-
- /*
+ * Because an object can be a class that is an instance of itself, the
+ * class object's class structure should only be cleaned after most of the
+ * cleanup on the object is done.
+ *
* The class of objects needs some special care; if it is deleted (and
* we're not killing the whole interpreter) we force the delete of the
* class of classes now as well. Due to the incestuous nature of those two
* classes, if one goes the other must too and yet the tangle can
* sometimes not go away automatically; we force it here. [Bug 2962664]
*/
- if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
- && !Deleted(fPtr->classCls->thisPtr)) {
+
+ if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr)
+ && !Tcl_InterpDeleted(interp)) {
Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
}
@@ -1267,30 +1247,47 @@ ObjectNamespaceDeleted(
ReleaseClassContents(interp, oPtr);
}
-
/*
* Delete the object structure itself.
*/
- oPtr->classPtr = NULL;
oPtr->namespacePtr = NULL;
-
- DelRef(fPtr->classCls->thisPtr);
- DelRef(fPtr->objectCls->thisPtr);
- DelRef(fPtr->classCls);
- DelRef(fPtr->objectCls);
- if (finished) {
- /*
- * ObjectRenamedTrace called us, and not the other way around.
- */
- DelRef(oPtr);
- } else {
- /*
- * ObjectRenamedTrace will call DelRef(oPtr).
- */
- }
+ oPtr->selfCls = NULL;
+ TclOODecrRefCount(oPtr);
return;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODecrRefCount --
+ *
+ * Decrement the refcount of an object and deallocate storage then object
+ * is no longer referenced. Returns 1 if storage was deallocated, and 0
+ * otherwise.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOODecrRefCount(
+ Object *oPtr)
+{
+ if (oPtr->refCount-- <= 1) {
+ Class *clsPtr = oPtr->classPtr;
+
+ if (oPtr->classPtr != NULL) {
+ ckfree(clsPtr->superclasses.list);
+ ckfree(clsPtr->subclasses.list);
+ ckfree(clsPtr->instances.list);
+ ckfree(clsPtr->mixinSubs.list);
+ ckfree(clsPtr->mixins.list);
+ ckfree(oPtr->classPtr);
+ }
+ ckfree(oPtr);
+ return 1;
+ }
+ return 0;
}
/*
@@ -1304,36 +1301,28 @@ ObjectNamespaceDeleted(
* ----------------------------------------------------------------------
*/
-void
+int
TclOORemoveFromInstances(
Object *oPtr, /* The instance to remove. */
Class *clsPtr) /* The class (possibly) containing the
* reference to the instance. */
{
- int i;
+ int i, res = 0;
Object *instPtr;
- FOREACH(instPtr, clsPtr->instances) {
- if (oPtr == instPtr) {
- goto removeInstance;
- }
+ if (Deleted(clsPtr->thisPtr)) {
+ return res;
}
- return;
- removeInstance:
- if (Deleted(clsPtr->thisPtr)) {
- if (!IsRootClass(clsPtr)) {
- DelRef(clsPtr->instances.list[i]);
- }
- clsPtr->instances.list[i] = NULL;
- } else {
- clsPtr->instances.num--;
- if (i < clsPtr->instances.num) {
- clsPtr->instances.list[i] =
- clsPtr->instances.list[clsPtr->instances.num];
+ FOREACH(instPtr, clsPtr->instances) {
+ if (oPtr == instPtr) {
+ RemoveItem(Object, clsPtr->instances, i);
+ TclOODecrRefCount(oPtr);
+ res++;
+ break;
}
- clsPtr->instances.list[clsPtr->instances.num] = NULL;
}
+ return res;
}
/*
@@ -1354,9 +1343,6 @@ TclOOAddToInstances(
* assumed that the class is not already
* present as an instance in the class. */
{
- if (Deleted(clsPtr->thisPtr)) {
- return;
- }
if (clsPtr->instances.num >= clsPtr->instances.size) {
clsPtr->instances.size += ALLOC_CHUNK;
if (clsPtr->instances.size == ALLOC_CHUNK) {
@@ -1367,6 +1353,7 @@ TclOOAddToInstances(
}
}
clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
+ AddRef(oPtr);
}
/*
@@ -1375,36 +1362,32 @@ TclOOAddToInstances(
* TclOORemoveFromSubclasses --
*
* Utility function to remove a class from the list of subclasses within
- * another class.
+ * another class. Returns the number of removals performed.
*
* ----------------------------------------------------------------------
*/
-void
+int
TclOORemoveFromSubclasses(
Class *subPtr, /* The subclass to remove. */
Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
- int i;
+ int i, res = 0;
Class *subclsPtr;
- FOREACH(subclsPtr, superPtr->subclasses) {
- if (subPtr == subclsPtr) {
- goto removeSubclass;
- }
+ if (Deleted(superPtr->thisPtr)) {
+ return res;
}
- return;
- removeSubclass:
- if (!Deleted(superPtr->thisPtr)) {
- superPtr->subclasses.num--;
- if (i < superPtr->subclasses.num) {
- superPtr->subclasses.list[i] =
- superPtr->subclasses.list[superPtr->subclasses.num];
+ FOREACH(subclsPtr, superPtr->subclasses) {
+ if (subPtr == subclsPtr) {
+ RemoveItem(Class, superPtr->subclasses, i);
+ TclOODecrRefCount(subPtr->thisPtr);
+ res++;
}
- superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
}
+ return res;
}
/*
@@ -1431,13 +1414,14 @@ TclOOAddToSubclasses(
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
- superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK);
+ superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list,
sizeof(Class *) * superPtr->subclasses.size);
}
}
superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
+ AddRef(subPtr->thisPtr);
}
/*
@@ -1451,31 +1435,28 @@ TclOOAddToSubclasses(
* ----------------------------------------------------------------------
*/
-void
+int
TclOORemoveFromMixinSubs(
Class *subPtr, /* The subclass to remove. */
Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
- int i;
+ int i, res = 0;
Class *subclsPtr;
- FOREACH(subclsPtr, superPtr->mixinSubs) {
- if (subPtr == subclsPtr) {
- goto removeSubclass;
- }
+ if (Deleted(superPtr->thisPtr)) {
+ return res;
}
- return;
- removeSubclass:
- if (!Deleted(superPtr->thisPtr)) {
- superPtr->mixinSubs.num--;
- if (i < superPtr->mixinSubs.num) {
- superPtr->mixinSubs.list[i] =
- superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+ FOREACH(subclsPtr, superPtr->mixinSubs) {
+ if (subPtr == subclsPtr) {
+ RemoveItem(Class, superPtr->mixinSubs, i);
+ TclOODecrRefCount(subPtr->thisPtr);
+ res++;
+ break;
}
- superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
}
+ return res;
}
/*
@@ -1509,6 +1490,7 @@ TclOOAddToMixinSubs(
}
}
superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
+ AddRef(subPtr->thisPtr);
}
/*
@@ -1516,37 +1498,18 @@ TclOOAddToMixinSubs(
*
* AllocClass --
*
- * Allocate a basic class. Does not splice the class object into its
+ * Allocate a basic class. Does not add class to its
* class's instance list.
*
* ----------------------------------------------------------------------
*/
-static Class *
-AllocClass(
- Tcl_Interp *interp, /* Interpreter within which to allocate the
- * class. */
- Object *useThisObj) /* Object that is to act as the class
- * representation, or NULL if a new object
- * with automatic name is to be used. */
+static inline void
+InitClassPath(
+ Tcl_Interp *interp,
+ Class *clsPtr)
{
Foundation *fPtr = GetFoundation(interp);
- Class *clsPtr = ckalloc(sizeof(Class));
-
- /*
- * Make an object if we haven't been given one.
- */
-
- memset(clsPtr, 0, sizeof(Class));
- if (useThisObj == NULL) {
- clsPtr->thisPtr = AllocObject(interp, NULL, NULL, NULL);
- } else {
- clsPtr->thisPtr = useThisObj;
- }
-
- /*
- * Configure the namespace path for the class's object.
- */
if (fPtr->helpersNs != NULL) {
Tcl_Namespace *path[2];
@@ -1558,13 +1521,26 @@ AllocClass(
TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
&fPtr->ooNs);
}
+}
+
+static Class *
+AllocClass(
+ Tcl_Interp *interp, /* Interpreter within which to allocate the
+ * class. */
+ Object *useThisObj) /* Object that is to act as the class
+ * representation. */
+{
+ Foundation *fPtr = GetFoundation(interp);
+ Class *clsPtr = ckalloc(sizeof(Class));
+
+ memset(clsPtr, 0, sizeof(Class));
+ clsPtr->thisPtr = useThisObj;
/*
- * Class objects inherit from the class of classes unless they inherit
- * from some subclass of it. Enforce this right now.
+ * Configure the namespace path for the class's object.
*/
- clsPtr->thisPtr->selfCls = fPtr->classCls;
+ InitClassPath(interp, clsPtr);
/*
* Classes are subclasses of oo::object, i.e. the objects they create are
@@ -1574,6 +1550,7 @@ AllocClass(
clsPtr->superclasses.num = 1;
clsPtr->superclasses.list = ckalloc(sizeof(Class *));
clsPtr->superclasses.list[0] = fPtr->objectCls;
+ AddRef(fPtr->objectCls->thisPtr);
/*
* Finish connecting the class structure to the object structure.
@@ -1586,7 +1563,6 @@ AllocClass(
* fields.
*/
- clsPtr->refCount = 1;
Tcl_InitObjHashTable(&clsPtr->classMethods);
return clsPtr;
}
@@ -1620,7 +1596,9 @@ Tcl_NewObjectInstance(
ClientData clientData[4];
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
- if (oPtr == NULL) {return NULL;}
+ if (oPtr == NULL) {
+ return NULL;
+ }
/*
* Run constructors, except when objc < 0, which is a special flag case
@@ -1640,7 +1618,7 @@ Tcl_NewObjectInstance(
contextPtr->skip = skip;
/*
- * Adjust the ensmble tracking record if necessary. [Bug 3514761]
+ * Adjust the ensemble tracking record if necessary. [Bug 3514761]
*/
isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv);
@@ -1656,7 +1634,6 @@ Tcl_NewObjectInstance(
clientData[2] = state;
clientData[3] = &oPtr;
- AddRef(oPtr);
result = FinalizeAlloc(clientData, interp, result);
if (result != TCL_OK) {
return NULL;
@@ -1690,7 +1667,9 @@ TclNRNewObjectInstance(
Object *oPtr;
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
- if (oPtr == NULL) {return TCL_ERROR;}
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
/*
* Run constructors, except when objc < 0 (a special flag case used for
@@ -1723,7 +1702,6 @@ TclNRNewObjectInstance(
* Fire off the constructors non-recursively.
*/
- AddRef(oPtr);
TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
objectPtr);
TclPushTailcallPoint(interp);
@@ -1742,44 +1720,40 @@ TclNewObjectInstanceCommon(
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
const char *simpleName = NULL;
- Namespace *nsPtr = NULL, *dummy,
- *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
+ Namespace *nsPtr = NULL, *dummy;
+ Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
int isNew;
if (nameStr) {
- TclGetNamespaceForQualName(interp, nameStr, inNsPtr, TCL_CREATE_NS_IF_UNKNOWN,
- &nsPtr, &dummy, &dummy, &simpleName);
+ TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
+ TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName);
/*
* Disallow creation of an object over an existing command.
*/
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew);
- if (isNew) {
- /* Just kidding */
- Tcl_DeleteHashEntry(hPtr);
- } else {
+ if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create object \"%s\": command already exists with"
" that name", nameStr));
Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
return NULL;
}
+
+ /*
+ * We could make a hash entry! Don't actually want to do that here so
+ * nuke it immediately because we'll create it properly soon.
+ */
+
+ Tcl_DeleteHashEntry(hPtr);
}
/*
* Create the object.
*/
- /*
- * The command for the object could have the same name as the command
- * associated with classPtr, so protect the structure from deallocation
- * here.
- */
- AddRef(classPtr);
-
oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
- DelRef(classPtr);
oPtr->selfCls = classPtr;
TclOOAddToInstances(oPtr, classPtr);
@@ -1797,7 +1771,6 @@ TclNewObjectInstanceCommon(
*/
AllocClass(interp, oPtr);
- oPtr->selfCls = classPtr;
TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
} else {
oPtr->classPtr = NULL;
@@ -1819,8 +1792,8 @@ FinalizeAlloc(
Tcl_Object *objectPtr = data[3];
/*
- * Ensure an error if the object was deleted in the constructor.
- * Don't want to lose errors by accident. [Bug 2903011]
+ * Ensure an error if the object was deleted in the constructor. Don't
+ * want to lose errors by accident. [Bug 2903011]
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
@@ -1829,7 +1802,6 @@ FinalizeAlloc(
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
}
- TclOODeleteContext(contextPtr);
if (result != TCL_OK) {
Tcl_DiscardInterpState(state);
@@ -1843,12 +1815,22 @@ FinalizeAlloc(
(void) TclOOObjectName(interp, oPtr);
Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
- DelRef(oPtr);
+
+ /*
+ * This decrements the refcount of oPtr.
+ */
+
+ TclOODeleteContext(contextPtr);
return TCL_ERROR;
}
Tcl_RestoreInterpState(interp, state);
*objectPtr = (Tcl_Object) oPtr;
- DelRef(oPtr);
+
+ /*
+ * This decrements the refcount of oPtr.
+ */
+
+ TclOODeleteContext(contextPtr);
return TCL_OK;
}
@@ -1957,7 +1939,6 @@ Tcl_CopyObjectInstance(
o2Ptr->flags = oPtr->flags & ~(
OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
-
/*
* Copy the object's metadata.
*/
@@ -2969,7 +2950,7 @@ int
Tcl_ObjectDeleted(
Tcl_Object object)
{
- return Deleted(object) ? 1 : 0;
+ return ((Object *)object)->command == NULL;
}
Tcl_Object
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index d4e1e34..7da9da0 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -110,7 +110,12 @@ TclOODeleteContext(
TclOODeleteChain(contextPtr->callPtr);
if (oPtr != NULL) {
TclStackFree(oPtr->fPtr->interp, contextPtr);
- DelRef(oPtr);
+
+ /*
+ * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore
+ */
+
+ TclOODecrRefCount(oPtr);
}
}
@@ -900,6 +905,7 @@ InitCallChain(
* ----------------------------------------------------------------------
*
* IsStillValid --
+ *
* Calculates whether the given call chain can be used for executing a
* method for the given object. The condition on a chain from a cached
* location being reusable is:
@@ -1171,6 +1177,11 @@ TclOOGetCallContext(
returnContext:
contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
contextPtr->oPtr = oPtr;
+
+ /*
+ * Corresponding TclOODecrRefCount() in TclOODeleteContext
+ */
+
AddRef(oPtr);
contextPtr->callPtr = callPtr;
contextPtr->skip = 2;
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index b0bfd9c..c08b350 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -123,6 +123,7 @@ static const struct DeclaredSlot slots[] = {
* ----------------------------------------------------------------------
*
* BumpGlobalEpoch --
+ *
* Utility that ensures that call chains that are invalid will get thrown
* away at an appropriate time. Note that exactly which epoch gets
* advanced will depend on exactly what the class is tangled up in; in
@@ -167,6 +168,7 @@ BumpGlobalEpoch(
* ----------------------------------------------------------------------
*
* RecomputeClassCacheFlag --
+ *
* Determine whether the object is prototypical of its class, and hence
* able to use the class's method chain cache.
*
@@ -189,6 +191,7 @@ RecomputeClassCacheFlag(
* ----------------------------------------------------------------------
*
* TclOOObjectSetFilters --
+ *
* Install a list of filter method names into an object.
*
* ----------------------------------------------------------------------
@@ -247,6 +250,7 @@ TclOOObjectSetFilters(
* ----------------------------------------------------------------------
*
* TclOOClassSetFilters --
+ *
* Install a list of filter method names into a class.
*
* ----------------------------------------------------------------------
@@ -309,6 +313,7 @@ TclOOClassSetFilters(
* ----------------------------------------------------------------------
*
* TclOOObjectSetMixins --
+ *
* Install a list of mixin classes into an object.
*
* ----------------------------------------------------------------------
@@ -326,9 +331,7 @@ TclOOObjectSetMixins(
if (numMixins == 0) {
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
- }
+ TclOORemoveFromInstances(oPtr, mixinPtr);
}
ckfree(oPtr->mixins.list);
oPtr->mixins.num = 0;
@@ -352,6 +355,13 @@ TclOOObjectSetMixins(
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr != oPtr->selfCls) {
TclOOAddToInstances(oPtr, mixinPtr);
+
+ /*
+ * Corresponding TclOODecrRefCount() is in the caller of this
+ * function.
+ */
+
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
}
}
@@ -362,6 +372,7 @@ TclOOObjectSetMixins(
* ----------------------------------------------------------------------
*
* TclOOClassSetMixins --
+ *
* Install a list of mixin classes into a class.
*
* ----------------------------------------------------------------------
@@ -399,6 +410,13 @@ TclOOClassSetMixins(
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
+
+ /*
+ * Corresponding TclOODecrRefCount() is in the caller of this
+ * function.
+ */
+
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
}
BumpGlobalEpoch(interp, classPtr);
@@ -408,6 +426,7 @@ TclOOClassSetMixins(
* ----------------------------------------------------------------------
*
* RenameDeleteMethod --
+ *
* Core of the code to rename and delete methods.
*
* ----------------------------------------------------------------------
@@ -497,6 +516,7 @@ RenameDeleteMethod(
* ----------------------------------------------------------------------
*
* TclOOUnknownDefinition --
+ *
* Handles what happens when an unknown command is encountered during the
* processing of a definition script. Works by finding a command in the
* operating definition namespace that the requested command is a unique
@@ -575,6 +595,7 @@ TclOOUnknownDefinition(
* ----------------------------------------------------------------------
*
* FindCommand --
+ *
* Specialized version of Tcl_FindCommand that handles command prefixes
* and disallows namespace magic.
*
@@ -635,6 +656,7 @@ FindCommand(
* ----------------------------------------------------------------------
*
* InitDefineContext --
+ *
* Does the magic incantations necessary to push the special stack frame
* used when processing object definitions. It is up to the caller to
* dispose of the frame (with TclPopStackFrame) when finished.
@@ -660,7 +682,9 @@ InitDefineContext(
return TCL_ERROR;
}
- /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */
+ /*
+ * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules.
+ */
(void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, FRAME_IS_OO_DEFINE);
@@ -675,6 +699,7 @@ InitDefineContext(
* ----------------------------------------------------------------------
*
* TclOOGetDefineCmdContext --
+ *
* Extracts the magic token from the current stack frame, or returns NULL
* (and leaves an error message) otherwise.
*
@@ -711,6 +736,7 @@ TclOOGetDefineCmdContext(
* ----------------------------------------------------------------------
*
* GetClassInOuterContext --
+ *
* Wrapper round Tcl_GetObjectFromObj to perform the lookup in the
* context that called oo::define (or equivalent). Note that this may
* have to go up multiple levels to get the level that we started doing
@@ -753,6 +779,7 @@ GetClassInOuterContext(
* ----------------------------------------------------------------------
*
* GenerateErrorInfo --
+ *
* Factored out code to generate part of the error trace messages.
*
* ----------------------------------------------------------------------
@@ -791,6 +818,7 @@ GenerateErrorInfo(
* ----------------------------------------------------------------------
*
* MagicDefinitionInvoke --
+ *
* Part of the implementation of the "oo::define" and "oo::objdefine"
* commands that is used to implement the more-than-one-argument case,
* applying ensemble-like tricks with dispatch so that error messages are
@@ -854,6 +882,7 @@ MagicDefinitionInvoke(
* ----------------------------------------------------------------------
*
* TclOODefineObjCmd --
+ *
* Implementation of the "oo::define" command. Works by effectively doing
* the same as 'namespace eval', but with extra magic applied so that the
* object to be modified is known to the commands in the target
@@ -914,7 +943,7 @@ TclOODefineObjCmd(
} else {
result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv);
}
- DelRef(oPtr);
+ TclOODecrRefCount(oPtr);
/*
* Restore the previous "current" namespace.
@@ -928,6 +957,7 @@ TclOODefineObjCmd(
* ----------------------------------------------------------------------
*
* TclOOObjDefObjCmd --
+ *
* Implementation of the "oo::objdefine" command. Works by effectively
* doing the same as 'namespace eval', but with extra magic applied so
* that the object to be modified is known to the commands in the target
@@ -981,7 +1011,7 @@ TclOOObjDefObjCmd(
} else {
result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv);
}
- DelRef(oPtr);
+ TclOODecrRefCount(oPtr);
/*
* Restore the previous "current" namespace.
@@ -995,6 +1025,7 @@ TclOOObjDefObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineSelfObjCmd --
+ *
* Implementation of the "self" subcommand of the "oo::define" command.
* Works by effectively doing the same as 'namespace eval', but with
* extra magic applied so that the object to be modified is known to the
@@ -1048,7 +1079,7 @@ TclOODefineSelfObjCmd(
} else {
result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv);
}
- DelRef(oPtr);
+ TclOODecrRefCount(oPtr);
/*
* Restore the previous "current" namespace.
@@ -1062,6 +1093,7 @@ TclOODefineSelfObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineObjSelfObjCmd --
+ *
* Implementation of the "self" subcommand of the "oo::objdefine"
* command.
*
@@ -1095,6 +1127,7 @@ TclOODefineObjSelfObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineClassObjCmd --
+ *
* Implementation of the "class" subcommand of the "oo::objdefine"
* command.
*
@@ -1168,11 +1201,14 @@ TclOODefineClassObjCmd(
if (oPtr->selfCls != clsPtr) {
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+
+ /*
+ * Reference count already incremented a few lines up.
+ */
+
oPtr->selfCls = clsPtr;
+
TclOOAddToInstances(oPtr, oPtr->selfCls);
- if (!(clsPtr->thisPtr->flags & OBJECT_DELETED)) {
- oPtr->flags &= ~CLASS_GONE;
- }
if (oPtr->classPtr != NULL) {
BumpGlobalEpoch(interp, oPtr->classPtr);
} else {
@@ -1186,6 +1222,7 @@ TclOODefineClassObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineConstructorObjCmd --
+ *
* Implementation of the "constructor" subcommand of the "oo::define"
* command.
*
@@ -1254,6 +1291,7 @@ TclOODefineConstructorObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineDeleteMethodObjCmd --
+ *
* Implementation of the "deletemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1310,6 +1348,7 @@ TclOODefineDeleteMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineDestructorObjCmd --
+ *
* Implementation of the "destructor" subcommand of the "oo::define"
* command.
*
@@ -1374,6 +1413,7 @@ TclOODefineDestructorObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineExportObjCmd --
+ *
* Implementation of the "export" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1468,6 +1508,7 @@ TclOODefineExportObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineForwardObjCmd --
+ *
* Implementation of the "forward" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1528,6 +1569,7 @@ TclOODefineForwardObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineMethodObjCmd --
+ *
* Implementation of the "method" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1585,6 +1627,7 @@ TclOODefineMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineMixinObjCmd --
+ *
* Implementation of the "mixin" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1628,6 +1671,13 @@ TclOODefineMixinObjCmd(
goto freeAndError;
}
mixins[i-1] = clsPtr;
+
+ /*
+ * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins,
+ * TclOOClassSetMixinsk, or just below if this function fails.
+ */
+
+ AddRef(mixins[i-1]->thisPtr);
}
if (isInstanceMixin) {
@@ -1640,6 +1690,9 @@ TclOODefineMixinObjCmd(
return TCL_OK;
freeAndError:
+ while (--i > 0) {
+ TclOODecrRefCount(mixins[i]->thisPtr);
+ }
TclStackFree(interp, mixins);
return TCL_ERROR;
}
@@ -1648,6 +1701,7 @@ TclOODefineMixinObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineRenameMethodObjCmd --
+ *
* Implementation of the "renamemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1704,6 +1758,7 @@ TclOODefineRenameMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineUnexportObjCmd --
+ *
* Implementation of the "unexport" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1798,6 +1853,7 @@ TclOODefineUnexportObjCmd(
* ----------------------------------------------------------------------
*
* Tcl_ClassSetConstructor, Tcl_ClassSetDestructor --
+ *
* How to install a constructor or destructor into a class; API to call
* from C.
*
@@ -1852,6 +1908,7 @@ Tcl_ClassSetDestructor(
* ----------------------------------------------------------------------
*
* TclOODefineSlots --
+ *
* Create the "::oo::Slot" class and its standard instances. Class
* definition is empty at the stage (added by scripting).
*
@@ -1895,6 +1952,7 @@ TclOODefineSlots(
* ----------------------------------------------------------------------
*
* ClassFilterGet, ClassFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::define"
* command.
*
@@ -1974,6 +2032,7 @@ ClassFilterSet(
* ----------------------------------------------------------------------
*
* ClassMixinGet, ClassMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::define"
* command.
*
@@ -2055,6 +2114,7 @@ ClassMixinSet(
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
+ i--;
goto freeAndError;
}
if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
@@ -2063,6 +2123,13 @@ ClassMixinSet(
Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
goto freeAndError;
}
+
+ /*
+ * Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or
+ * just below if this function fails.
+ */
+
+ AddRef(mixins[i]->thisPtr);
}
TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
@@ -2070,6 +2137,9 @@ ClassMixinSet(
return TCL_OK;
freeAndError:
+ while (i-- > 0) {
+ TclOODecrRefCount(mixins[i]->thisPtr);
+ }
TclStackFree(interp, mixins);
return TCL_ERROR;
}
@@ -2078,6 +2148,7 @@ ClassMixinSet(
* ----------------------------------------------------------------------
*
* ClassSuperGet, ClassSuperSet --
+ *
* Implementation of the "superclass" slot accessors of the "oo::define"
* command.
*
@@ -2172,16 +2243,24 @@ ClassSuperSet(
if (superc == 0) {
superclasses = ckrealloc(superclasses, sizeof(Class *));
- superclasses[0] = oPtr->fPtr->objectCls;
- superc = 1;
if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
superclasses[0] = oPtr->fPtr->classCls;
+ } else {
+ superclasses[0] = oPtr->fPtr->objectCls;
}
+ superc = 1;
+
+ /*
+ * Corresponding TclOODecrRefCount is near the end of this function.
+ */
+
+ AddRef(superclasses[0]->thisPtr);
} else {
for (i=0 ; i<superc ; i++) {
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
+ i--;
goto failedAfterAlloc;
}
for (j=0 ; j<i ; j++) {
@@ -2198,9 +2277,19 @@ ClassSuperSet(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
+ for (; i > 0; i--) {
+ TclOODecrRefCount(superclasses[i]->thisPtr);
+ }
ckfree(superclasses);
return TCL_ERROR;
}
+
+ /*
+ * Corresponding TclOODecrRefCount() is near the end of this
+ * function.
+ */
+
+ AddRef(superclasses[i]->thisPtr);
}
}
@@ -2221,6 +2310,12 @@ ClassSuperSet(
oPtr->classPtr->superclasses.num = superc;
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOOAddToSubclasses(oPtr->classPtr, superPtr);
+
+ /*
+ * To account for the AddRef() earlier in this function.
+ */
+
+ TclOODecrRefCount(superPtr->thisPtr);
}
BumpGlobalEpoch(interp, oPtr->classPtr);
@@ -2231,6 +2326,7 @@ ClassSuperSet(
* ----------------------------------------------------------------------
*
* ClassVarsGet, ClassVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::define"
* command.
*
@@ -2373,6 +2469,7 @@ ClassVarsSet(
* ----------------------------------------------------------------------
*
* ObjectFilterGet, ObjectFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::objdefine"
* command.
*
@@ -2440,6 +2537,7 @@ ObjFilterSet(
* ----------------------------------------------------------------------
*
* ObjectMixinGet, ObjectMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::objdefine"
* command.
*
@@ -2511,9 +2609,19 @@ ObjMixinSet(
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
+ while (i-- > 0) {
+ TclOODecrRefCount(mixins[i]->thisPtr);
+ }
TclStackFree(interp, mixins);
return TCL_ERROR;
}
+
+ /*
+ * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or
+ * just above if this function fails.
+ */
+
+ AddRef(mixins[i]->thisPtr);
}
TclOOObjectSetMixins(oPtr, mixinc, mixins);
@@ -2525,6 +2633,7 @@ ObjMixinSet(
* ----------------------------------------------------------------------
*
* ObjectVarsGet, ObjectVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::objdefine"
* command.
*
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 83b4d58..084c026 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -193,9 +193,10 @@ typedef struct Object {
* destroyed. */
#define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been
* called. */
-#define CLASS_GONE 4 /* Indicates that the class of this object has
- * been deleted, and so the object should not
- * attempt to remove itself from its class. */
+#define CLASS_GONE 4 /* Obsolete. Indicates that the class of this
+ * object has been deleted, and so the object
+ * should not attempt to remove itself from its
+ * class. */
#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
* the class hierarchy and should be treated
* specially during teardown. */
@@ -222,10 +223,6 @@ typedef struct Object {
typedef struct Class {
Object *thisPtr; /* Reference to the object associated with
* this class. */
- int refCount; /* Number of strong references to this class.
- * Weak references are not counted; the
- * purpose of this is to avoid Tcl_Preserve as
- * that is quite slow. */
int flags; /* Assorted flags. */
LIST_STATIC(struct Class *) superclasses;
/* List of superclasses, used for generation
@@ -499,6 +496,7 @@ MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp,
Class *classPtr,
const char *nameStr,
const char *nsNameStr);
+MODULE_SCOPE int TclOODecrRefCount(Object *oPtr);
MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
@@ -528,10 +526,10 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp,
MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
-MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
-MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr,
+MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
+MODULE_SCOPE int TclOORemoveFromMixinSubs(Class *subPtr,
Class *mixinPtr);
-MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr,
+MODULE_SCOPE int TclOORemoveFromSubclasses(Class *subPtr,
Class *superPtr);
MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp,
CallChain *callPtr);
@@ -546,18 +544,21 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
#include "tclOOIntDecls.h"
/*
+ * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release.
+ */
+
+#define AddRef(ptr) ((ptr)->refCount++)
+
+/*
* A convenience macro for iterating through the lists used in the internal
- * memory management of objects. This is a bit gnarly because we want to do
- * the assignment of the picked-out value only when the body test succeeds,
- * but we cannot rely on the assigned value being useful, forcing us to do
- * some nasty stuff with the comma operator. The compiler's optimizer should
- * be able to sort it all out!
- *
+ * memory management of objects.
* REQUIRES DECLARATION: int i;
*/
#define FOREACH(var,ary) \
- for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++)
+ for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \
+ continue; \
+ } else if (var = (ary).list[i], 1)
/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
@@ -592,17 +593,6 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
} \
} while(0)
-/*
- * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release.
- */
-
-#define AddRef(ptr) ((ptr)->refCount++)
-#define DelRef(ptr) do { \
- if ((ptr)->refCount-- <= 1) { \
- ckfree(ptr); \
- } \
- } while(0)
-
#endif /* TCL_OO_INTERNAL_H */
/*
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 4ec0a57..b922c39 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -242,6 +242,7 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
* implementations.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
static const Tcl_ObjType oldBooleanType = {
"boolean", /* name */
NULL, /* freeIntRepProc */
@@ -249,8 +250,13 @@ static const Tcl_ObjType oldBooleanType = {
NULL, /* updateStringProc */
TclSetBooleanFromAny /* setFromAnyProc */
};
+#endif
const Tcl_ObjType tclBooleanType = {
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
"booleanString", /* name */
+#else
+ "boolean", /* name */
+#endif
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
@@ -406,7 +412,9 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclProcBodyType);
/* For backward compatibility only ... */
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Tcl_RegisterObjType(&oldBooleanType);
+#endif
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_RegisterObjType(&tclWideIntType);
#endif
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index cdf9a8b..288d5dc 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -948,6 +948,7 @@ Tcl_PackageObjCmd(
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
}
ckfree(availPtr);
}
@@ -1001,6 +1002,7 @@ Tcl_PackageObjCmd(
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
}
break;
}
@@ -1012,7 +1014,7 @@ Tcl_PackageObjCmd(
}
if (availPtr == NULL) {
availPtr = ckalloc(sizeof(PkgAvail));
- availPtr->pkgIndex = 0;
+ availPtr->pkgIndex = NULL;
DupBlock(availPtr->version, argv3, (unsigned) length + 1);
if (prevPtr == NULL) {
@@ -1384,6 +1386,7 @@ TclFreePackageInfo(
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
}
ckfree(availPtr);
}
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 385ce4f..ae75e44 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -522,7 +522,7 @@ Tcl_GetUniChar(
*
* Get the Unicode form of the String object. If the object is not
* already a String object, it will be converted to one. If the String
- * object does not have a Unicode rep, then one is create from the UTF
+ * object does not have a Unicode rep, then one is created from the UTF
* string format.
*
* Results:
@@ -656,6 +656,17 @@ Tcl_GetRange(
stringPtr = GET_STRING(objPtr);
}
+#if TCL_UTF_MAX == 4
+ /* See: bug [11ae2be95dac9417] */
+ if ((first>0) && ((stringPtr->unicode[first]&0xFC00) == 0xDC00)
+ && ((stringPtr->unicode[first-1]&0xFC00) == 0xD800)) {
+ ++first;
+ }
+ if ((last+1<stringPtr->numChars) && ((stringPtr->unicode[last+1]&0xFC00) == 0xDC00)
+ && ((stringPtr->unicode[last]&0xFC00) == 0xD800)) {
+ ++last;
+ }
+#endif
return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1);
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 227bf02..b488754 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -71,9 +71,19 @@ static int TclSockMinimumBuffersOld(int sock, int size)
# define TclWinSetSockOpt 0
# define TclWinNToHS 0
# define TclWinGetPlatformId 0
+# define TclWinResetInterfaces 0
+# define TclWinSetInterfaces 0
+# define TclWinGetPlatformId 0
# define TclBNInitBignumFromWideUInt 0
# define TclBNInitBignumFromWideInt 0
# define TclBNInitBignumFromLong 0
+# define Tcl_Backslash 0
+# define Tcl_GetDefaultEncodingDir 0
+# define Tcl_SetDefaultEncodingDir 0
+# define Tcl_EvalTokens 0
+# define Tcl_CreateMathFunc 0
+# define Tcl_GetMathFuncInfo 0
+# define Tcl_ListMathFuncs 0
#else
#define TclSetStartupScriptPath setStartupScriptPath
static void TclSetStartupScriptPath(Tcl_Obj *path)
@@ -100,11 +110,16 @@ static const char *TclGetStartupScriptFileName(void)
}
return Tcl_GetString(path);
}
-
#if defined(_WIN32) || defined(__CYGWIN__)
#undef TclWinNToHS
#undef TclWinGetPlatformId
-#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+#undef TclWinResetInterfaces
+#undef TclWinSetInterfaces
+static void
+doNothing(void)
+{
+ /* dummy implementation, no need to do anything */
+}
#define TclWinNToHS winNToHS
static unsigned short TclWinNToHS(unsigned short ns) {
return ntohs(ns);
@@ -115,10 +130,8 @@ TclWinGetPlatformId(void)
{
return 2; /* VER_PLATFORM_WIN32_NT */;
}
-#else
-#define TclWinNToHS 0
-#define TclWinGetPlatformId 0
-#endif
+#define TclWinResetInterfaces doNothing
+#define TclWinSetInterfaces (void (*) (int)) doNothing
#endif
# define TclBNInitBignumFromWideUInt TclInitBignumFromWideUInt
# define TclBNInitBignumFromWideInt TclInitBignumFromWideInt
@@ -133,14 +146,15 @@ TclWinGetPlatformId(void)
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty TclPlatIsAtty
-# define TclWinSetInterfaces (void (*) (int)) doNothing
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+static void
+doNothing(void)
+{
+ /* dummy implementation, no need to do anything */
+}
+#endif
# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
# define TclWinFlushDirtyChannels doNothing
-# define TclWinResetInterfaces doNothing
-
-#if TCL_UTF_MAX < 4
-static Tcl_Encoding winTCharEncoding;
-#endif
static int
TclpIsAtty(int fd)
@@ -201,19 +215,12 @@ TclpGetPid(Tcl_Pid pid)
return (int) (size_t) pid;
}
-static void
-doNothing(void)
-{
- /* dummy implementation, no need to do anything */
-}
-
char *
Tcl_WinUtfToTChar(
const char *string,
int len,
Tcl_DString *dsPtr)
{
-#if TCL_UTF_MAX > 3
WCHAR *wp;
int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0);
@@ -225,13 +232,6 @@ Tcl_WinUtfToTChar(
Tcl_DStringSetLength(dsPtr, 2*size);
wp[size] = 0;
return (char *)wp;
-#else
- if (!winTCharEncoding) {
- winTCharEncoding = Tcl_GetEncoding(0, "unicode");
- }
- return Tcl_UtfToExternalDString(winTCharEncoding,
- string, len, dsPtr);
-#endif
}
char *
@@ -240,7 +240,6 @@ Tcl_WinTCharToUtf(
int len,
Tcl_DString *dsPtr)
{
-#if TCL_UTF_MAX > 3
char *p;
int size;
@@ -256,13 +255,6 @@ Tcl_WinTCharToUtf(
Tcl_DStringSetLength(dsPtr, size);
p[size] = 0;
return p;
-#else
- if (!winTCharEncoding) {
- winTCharEncoding = Tcl_GetEncoding(0, "unicode");
- }
- return Tcl_ExternalToUtfDString(winTCharEncoding,
- string, len, dsPtr);
-#endif
}
#if defined(TCL_WIDE_INT_IS_LONG)
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 7fb1f29..a891242 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -305,14 +305,6 @@ static int TestlinkCmd(ClientData dummy,
static int TestlocaleCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-#ifndef TCL_NO_DEPRECATED
-static int TestMathFunc(ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr);
-static int TestMathFunc2(ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr);
-#endif /* TCL_NO_DEPRECATED */
static int TestmainthreadCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestsetmainloopCmd(ClientData dummy,
@@ -555,10 +547,6 @@ int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
-#ifndef TCL_NO_DEPRECATED
- Tcl_ValueType t3ArgTypes[2];
-#endif /* TCL_NO_DEPRECATED */
-
Tcl_Obj *listPtr;
Tcl_Obj **objv;
int objc, index;
@@ -711,10 +699,6 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
-#ifndef TCL_NO_DEPRECATED
- Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123);
- Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345);
-#endif /* TCL_NO_DEPRECATED */
Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
@@ -725,13 +709,6 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
(ClientData) 0, NULL);
#endif
-#ifndef TCL_NO_DEPRECATED
- t3ArgTypes[0] = TCL_EITHER;
- t3ArgTypes[1] = TCL_EITHER;
- Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
- NULL);
-#endif /* TCL_NO_DEPRECATED */
-
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
@@ -3357,146 +3334,6 @@ TestlocaleCmd(
/*
*----------------------------------------------------------------------
*
- * TestMathFunc --
- *
- * This is a user-defined math procedure to test out math procedures
- * with no arguments.
- *
- * Results:
- * A normal Tcl completion code.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-#ifndef TCL_NO_DEPRECATED
-static int
-TestMathFunc(
- ClientData clientData, /* Integer value to return. */
- Tcl_Interp *interp, /* Not used. */
- Tcl_Value *args, /* Not used. */
- Tcl_Value *resultPtr) /* Where to store result. */
-{
- resultPtr->type = TCL_INT;
- resultPtr->intValue = PTR2INT(clientData);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TestMathFunc2 --
- *
- * This is a user-defined math procedure to test out math procedures
- * that do have arguments, in this case 2.
- *
- * Results:
- * A normal Tcl completion code.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-static int
-TestMathFunc2(
- ClientData clientData, /* Integer value to return. */
- Tcl_Interp *interp, /* Used to report errors. */
- Tcl_Value *args, /* Points to an array of two Tcl_Value structs
- * for the two arguments. */
- Tcl_Value *resultPtr) /* Where to store the result. */
-{
- int result = TCL_OK;
-
- /*
- * Return the maximum of the two arguments with the correct type.
- */
-
- if (args[0].type == TCL_INT) {
- int i0 = args[0].intValue;
-
- if (args[1].type == TCL_INT) {
- int i1 = args[1].intValue;
-
- resultPtr->type = TCL_INT;
- resultPtr->intValue = ((i0 > i1)? i0 : i1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d0 = i0;
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- Tcl_WideInt w0 = Tcl_LongAsWide(i0);
- Tcl_WideInt w1 = args[1].wideValue;
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
- result = TCL_ERROR;
- }
- } else if (args[0].type == TCL_DOUBLE) {
- double d0 = args[0].doubleValue;
-
- if (args[1].type == TCL_INT) {
- double d1 = args[1].intValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- double d1 = Tcl_WideAsDouble(args[1].wideValue);
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
- result = TCL_ERROR;
- }
- } else if (args[0].type == TCL_WIDE_INT) {
- Tcl_WideInt w0 = args[0].wideValue;
-
- if (args[1].type == TCL_INT) {
- Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue);
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d0 = Tcl_WideAsDouble(w0);
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- Tcl_WideInt w1 = args[1].wideValue;
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
- result = TCL_ERROR;
- }
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 1", NULL);
- result = TCL_ERROR;
- }
- return result;
-}
-#endif /* TCL_NO_DEPRECATED */
-
-/*
- *----------------------------------------------------------------------
- *
* CleanupTestSetassocdataTests --
*
* This function is called when an interpreter is deleted to clean
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 43636b4..2d8750d 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -68,11 +68,7 @@ static const unsigned char totalBytes[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
-#if TCL_UTF_MAX > 3
4,4,4,4,4,4,4,4,
-#else
- 1,1,1,1,1,1,1,1,
-#endif
1,1,1,1,1,1,1,1
};
@@ -328,13 +324,22 @@ Tcl_UtfToUniChar(
* represents itself.
*/
}
-#if TCL_UTF_MAX > 3
else if (byte < 0xF8) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX == 3
+ byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
+ | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)) - 0x10000;
+ if (byte & 0x100000) {
+ /* out of range, < 0x10000 or > 0x10ffff */
+ } else {
+ /* produce replacement character, and advance source pointer */
+ *chPtr = (Tcl_UniChar) 0xFFFD;
+ return 4;
+ }
+#elif TCL_UTF_MAX == 4
Tcl_UniChar surrogate;
byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
@@ -365,7 +370,6 @@ Tcl_UtfToUniChar(
* represents itself.
*/
}
-#endif
*chPtr = (Tcl_UniChar) byte;
return 1;
@@ -499,13 +503,13 @@ Tcl_NumUtfChars(
}
if (i < 0) i = INT_MAX; /* Bug [2738427] */
} else {
- register const char *endPtr = src + length - TCL_UTF_MAX;
+ register const char *endPtr = src + length - 4;
while (src < endPtr) {
src += TclUtfToUniChar(src, &ch);
i++;
}
- endPtr += TCL_UTF_MAX;
+ endPtr += 4;
while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) {
src += TclUtfToUniChar(src, &ch);
i++;
@@ -677,7 +681,7 @@ Tcl_UtfPrev(
int i, byte;
look = --src;
- for (i = 0; i < TCL_UTF_MAX; i++) {
+ for (i = 0; i < 4; i++) {
if (look < start) {
if (src < start) {
src = start;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 15018de..dcd0415 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1604,6 +1604,7 @@ Tcl_Merge(
return result;
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -1637,6 +1638,7 @@ Tcl_Backslash(
TclUtfToUniChar(buf, &ch);
return (char) ch;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test
index bae26a0..0136ccd 100644
--- a/tests/compExpr-old.test
+++ b/tests/compExpr-old.test
@@ -20,12 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
-
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
@@ -602,22 +596,6 @@ test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body {
test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body {
expr sin(1
} -returnCodes error -match glob -result *
-test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr 2*T1()
-} 246
-test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T2()*3
-} 1035
-test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T3(21, 37)
-} 37
-test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T3(21.2, 37)
-} 37.0
-test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T3(-21.2, -17.5)
-} -17.5
-
test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
set a(VALUE) ff15
diff --git a/tests/compExpr.test b/tests/compExpr.test
index 14c875d..3b44af8 100644
--- a/tests/compExpr.test
+++ b/tests/compExpr.test
@@ -16,12 +16,6 @@ if {"::tcltest" ni [namespace children]} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
-
# Constrain memory leak tests
testConstraint memory [llength [info commands memory]]
@@ -319,12 +313,6 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body {
expr {do_it()}
} -returnCodes error -match glob -result {* "*do_it"}
-test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr 3*T1()-1
-} 368
-test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T2()*3
-} 1035
test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body {
expr {atan2(1.0)}
} -returnCodes error -match glob -result {too few arguments for math function*}
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 8c159b2..a73b77a 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -24,12 +24,6 @@ testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
-
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
@@ -847,12 +841,6 @@ test expr-old-32.41 {math functions in expressions} {
test expr-old-32.42 {math functions in expressions} {
list [catch {expr hypot(5*.8,3)} msg] $msg
} {0 5.0}
-test expr-old-32.43 {math functions in expressions} testmathfunctions {
- expr 2*T1()
-} 246
-test expr-old-32.44 {math functions in expressions} testmathfunctions {
- expr T2()*3
-} 1035
test expr-old-32.45 {math functions in expressions} {
expr (0 <= rand()) && (rand() < 1)
} {1}
@@ -952,11 +940,6 @@ test expr-old-34.15 {errors in math functions} {
test expr-old-34.16 {errors in math functions} {
expr round(-1.0e30)
} -1000000000000000019884624838656
-test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \
- -body {
- list [catch {expr T1(4)} msg] $msg
- } -match glob -result {1 {too many arguments for math function*}}
-
test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
expr 0o289
} -returnCodes error -match glob -result {*invalid octal number*}
diff --git a/tests/expr.test b/tests/expr.test
index 8e083c5..0b3620a 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -18,10 +18,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-testConstraint testmathfunctions [expr {
- ([catch {expr T1()} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"})
-}]
-
# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.
@@ -685,41 +681,6 @@ test expr-15.5 {CompileMathFuncCall: too few arguments} -body {
test expr-15.6 {CompileMathFuncCall: missing ')'} -body {
expr sin(1
} -returnCodes error -match glob -result *
-test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr 2*T1()
-} 246
-test expr-15.8 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T2()*3
-} 1035
-test expr-15.9 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T3(21, 37)
-} 37
-test expr-15.10 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T3(21.2, 37)
-} 37.0
-test expr-15.11 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T3(-21.2, -17.5)
-} -17.5
-test expr-15.12 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(21, wide(37))
-} 37
-test expr=15.13 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(wide(21), 37)
-} 37
-test expr=15.14 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(wide(21), wide(37))
-} 37
-test expr-15.15 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(21.0, wide(37))
-} 37.0
-test expr-15.16 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(wide(21), 37.0)
-} 37.0
-test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints {
- testmathfunctions
-} -body {
- expr T3(0,"a")
-} -returnCodes error -result {argument to math function didn't have numeric value}
test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
diff --git a/tests/oo.test b/tests/oo.test
index b9c5067..3be5f79 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -47,7 +47,7 @@ test oo-0.2 {basic test of OO's ability to clean up its initial state} {
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
- [oo::object new] destroy
+ [oo::object new] destroy
}
} -constraints memory -result 0
test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
@@ -131,6 +131,10 @@ test oo-1.4 {basic test of OO functionality} -body {
test oo-1.4.1 {fully-qualified nested name} -body {
oo::object create ::one::two::three
} -result {::one::two::three}
+test oo-1.4.2 {automatic command name has same name as namespace} -body {
+ set obj [oo::object new]
+ expr {[info object namespace $obj] == $obj}
+} -result 1
test oo-1.5 {basic test of OO functionality} -body {
oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
@@ -1514,9 +1518,9 @@ test oo-11.6 {
# No segmentation fault
return done
-} -cleanup {
+} -result done -cleanup {
rename obj1 {}
-} -result done
+}
test oo-12.1 {OO: filters} {
oo::class create Aclass
@@ -3891,9 +3895,6 @@ test oo-35.6 {
rename obj {}
} -result done
-
-
-
test oo-36.1 {TIP #470: introspection within oo::define} {
oo::define oo::object self
} ::oo::object
diff --git a/tests/safe.test b/tests/safe.test
index 33ee166..df60de6 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -180,17 +180,17 @@ test safe-6.3 {test safe interpreters knowledge of the world} {
# leaking infos, but they still do...
# high level general test
-test safe-7.1 {tests that everything works at high level} {
+test safe-7.1 {tests that everything works at high level} -body {
set i [safe::interpCreate]
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a slave works like in the master)
- set v [interp eval $i {package require http 1}]
+ set v [interp eval $i {package require http 2}]
# no error shall occur:
- interp eval $i {http_config}
+ interp eval $i {http::config}
safe::interpDelete $i
set v
-} 1.0
+} -match glob -result 2.*
test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
diff --git a/tests/string.test b/tests/string.test
index cebaf4c..b75c900 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -24,6 +24,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
+testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
@@ -1288,6 +1289,9 @@ test string-12.22 {string range, shimmering binary/index} {
binary scan $s a* x
string range $s $s end
} 000000001
+test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} fullutf {
+ list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]
+} [list \U100000 {} b]
test string-13.1 {string repeat} {
list [catch {string repeat} msg] $msg
diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c
index cc66569..630460a 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -577,12 +577,6 @@ TclpSetInitialEncodings(void)
Tcl_DStringFree(&encodingName);
}
-void
-TclpSetInterfaces(void)
-{
- /* do nothing */
-}
-
static const char *
SearchKnownEncodings(
const char *encoding)
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index da1cdfe..599c126 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -32,10 +32,6 @@ static HINSTANCE hInstance; /* HINSTANCE of this DLL. */
#define cpuid __asm __emit 0fh __asm __emit 0a2h
#endif
-#if TCL_UTF_MAX < 4
-static Tcl_Encoding winTCharEncoding = NULL;
-#endif
-
/*
* The following declaration is for the VC++ DLL entry point.
*/
@@ -196,8 +192,6 @@ TclWinInit(
if (os.dwPlatformId != VER_PLATFORM_WIN32_NT) {
Tcl_Panic("Windows NT is the only supported platform");
}
-
- TclWinResetInterfaces();
}
/*
@@ -234,38 +228,10 @@ TclWinNoBackslash(
/*
*---------------------------------------------------------------------------
*
- * TclpSetInterfaces --
- *
- * A helper proc.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-void
-TclpSetInterfaces(void)
-{
-#if TCL_UTF_MAX < 4
- TclWinResetInterfaces();
- winTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
-#endif
-}
-
-/*
- *---------------------------------------------------------------------------
- *
* TclWinEncodingsCleanup --
*
- * Called during finalization to free up any encodings we use.
- *
- * We also clean up any memory allocated in our mount point map which is
- * used to follow certain kinds of symlinks. That code should never be
- * used once encodings are taken down.
+ * Called during finalization to clean up any memory allocated in our
+ * mount point map which is used to follow certain kinds of symlinks.
*
* Results:
* None.
@@ -281,8 +247,6 @@ TclWinEncodingsCleanup(void)
{
MountPointMap *dlIter, *dlIter2;
- TclWinResetInterfaces();
-
/*
* Clean up the mount point map.
*/
@@ -299,32 +263,6 @@ TclWinEncodingsCleanup(void)
}
/*
- *---------------------------------------------------------------------------
- *
- * TclWinResetInterfaces --
- *
- * Called during finalization to reset us to a safe state for reuse.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-void
-TclWinResetInterfaces(void)
-{
-#if TCL_UTF_MAX < 4
- if (winTCharEncoding != NULL) {
- Tcl_FreeEncoding(winTCharEncoding);
- winTCharEncoding = NULL;
- }
-#endif
-}
-
-/*
*--------------------------------------------------------------------
*
* TclWinDriveLetterForVolMountPoint
@@ -533,7 +471,6 @@ Tcl_WinUtfToTChar(
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
-#if TCL_UTF_MAX > 3
TCHAR *wp;
int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0);
@@ -545,10 +482,6 @@ Tcl_WinUtfToTChar(
Tcl_DStringSetLength(dsPtr, 2*size);
wp[size] = 0;
return wp;
-#else
- return (TCHAR *) Tcl_UtfToExternalDString(winTCharEncoding,
- string, len, dsPtr);
-#endif
}
char *
@@ -559,7 +492,6 @@ Tcl_WinTCharToUtf(
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
-#if TCL_UTF_MAX > 3
char *p;
int size;
@@ -575,10 +507,6 @@ Tcl_WinTCharToUtf(
Tcl_DStringSetLength(dsPtr, size);
p[size] = 0;
return p;
-#else
- return Tcl_ExternalToUtfDString(winTCharEncoding,
- (const char *) string, len, dsPtr);
-#endif
}
/*
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 2589630..381db65 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -152,13 +152,6 @@ Dde_Init(
return TCL_ERROR;
}
-#ifdef UNICODE
- if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "Win32s and Windows 9x are not supported platforms", -1));
- return TCL_ERROR;
- }
-#endif
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index dc8bba7..91f149b 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -487,18 +487,11 @@ TclpSetInitialEncodings(void)
{
Tcl_DString encodingName;
- TclpSetInterfaces();
Tcl_SetSystemEncoding(NULL,
Tcl_GetEncodingNameFromEnvironment(&encodingName));
Tcl_DStringFree(&encodingName);
}
-void TclWinSetInterfaces(
- int dummy) /* Not used. */
-{
- TclpSetInterfaces();
-}
-
const char *
Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr)