Index: .fossil-settings/crlf-glob ================================================================== --- .fossil-settings/crlf-glob +++ .fossil-settings/crlf-glob @@ -10,8 +10,10 @@ tools/tcl.wse.in win/buildall.vc.bat win/coffbase.txt win/makefile.vc win/rules.vc +win/rules-ext.vc +win/targets.vc win/tcl.dsp win/tcl.dsw win/tcl.hpj.in Index: .fossil-settings/crnl-glob ================================================================== --- .fossil-settings/crnl-glob +++ .fossil-settings/crnl-glob @@ -10,8 +10,10 @@ tools/tcl.wse.in win/buildall.vc.bat win/coffbase.txt win/makefile.vc win/rules.vc +win/rules-ext.vc +win/targets.vc win/tcl.dsp win/tcl.dsw win/tcl.hpj.in Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -42,7 +42,8 @@ unix/tclIndex unix/pkgs/* win/Debug* win/Release* win/pkgs/* +win/coffbase.txt win/tcl.hpj win/nmhlp-out.txt Index: .project ================================================================== --- .project +++ .project @@ -1,8 +1,8 @@ - tcl9 + tcl8 Index: README ================================================================== --- README +++ README @@ -1,7 +1,7 @@ README: Tcl - This is the Tcl 9.0a0 source distribution. + This is the Tcl 8.7a2 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. Contents -------- Index: changes ================================================================== --- changes +++ changes @@ -8232,11 +8232,11 @@ 2013-05-15 (enhancement) Improved [list {*}...] compile (fellows) 2013-05-16 (platform support) mingw-4.0 (nijtmans) -2013-05-19 (platform support) FreeBSD updates (gahr) +2013-05-19 (platform support) FreeBSD updates (cerutti) 2013-05-20 (bug fix)[3613567] access error temp file creation (keene) 2013-05-20 (bug fix)[3613569] temp file open fail can crash [load] (keene) @@ -8655,11 +8655,11 @@ 2016-05-13 (bug) registry package support any Unicode env (nijtmans) => registry 1.3.2 2016-05-21 (bug)[f7d4e] [namespace delete] performance (fellows) -2016-06-02 (TIP 447) execution time verbosity option (gahr) +2016-06-02 (TIP 447) execution time verbosity option (cerutti) => tcltest 2.4.0 2016-06-16 (bug)[16828b] crash due to [vwait] trace undo fail (dah,porter) 2016-06-16 (enhancement)[4b61af] good [info frame] from more cases (beric) @@ -8794,10 +8794,49 @@ 2017-07-17 (bug)[fb2208] Repeatable tclIndex generation (wiedemann,nijtmans) --- Released 8.6.7, August 9, 2017 --- http://core.tcl.tk/tcl/ for details +2017-08-10 [array names -regexp] supports backrefs (goth) + +2017-08-10 Fix gcc build failures due to #pragma placement (cassoff,fellows) + +2017-08-29 (bug)[b50fb2] exec redir append stdout and stderr to file (coulter) + +2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann) +=> http 2.8.12 + +2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter) + +2017-10-19 (bug)[1a5655] [info * methods] includes mixins (fellows) + +2017-10-23 tzdata updated to Olson's tzdata2017c (jima) + +2017-10-24 (bug)[fc1409] segfault in method cloning, oo-15.15 (coulter,fellows) + +2017-11-03 (bug)[6f2f83] More robust [load] for ReactOS (werner) + +2017-11-08 (bug)[3298012] Stop crash when hash tables overflow 32 bits (porter) + +2017-11-14 (bug)[5d6de6] Close failing case of [package prefer stable] (kupries) + +2017-11-17 (bug)[fab924] Fix misleading [load] message on Windows (oehlmann) + +2017-12-05 (bug)[4f6a1e] Crash when ensemble map and list are same (sebres) + +2017-12-06 (bug)[ce3a21] file normalize failure when tail is empty (porter) + +2017-12-08 (new)[TIP 477] nmake build system reform (nadkarni) + +2017-12-19 (bug)[586e71] EvalObjv exception handling at level #0 (sebres,porter) + +--- Released 8.6.8, December 22, 2017 --- http://core.tcl.tk/tcl/ for details + +Changes to 8.7a1 include all changes to the 8.6 line through 8.6.7, +plus the following, which focuses on the high-level feature changes +in this changeset (new minor version) rather than bug fixes: + 2016-03-17 (bug)[0b8c38] socket accept callbacks always in global ns (porter) *** POTENTIAL INCOMPATIBILITY *** 2016-07-01 Hack accommodations for legacy Itcl 3 disabled (porter) @@ -8834,10 +8873,9 @@ => TclOO 1.2.0 2017-06-23 (TIP 472) Support 0d as prefix of decimal numbers (iyer,griffin) 2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann) -=> http 2.8.12 2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter) --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details DELETED compat/float.h Index: compat/float.h ================================================================== --- compat/float.h +++ /dev/null @@ -1,14 +0,0 @@ -/* - * float.h -- - * - * This is a dummy header file to #include in Tcl when there - * is no float.h in /usr/include. Right now this file is empty: - * Tcl contains #ifdefs to deal with the lack of definitions; - * all it needs is for the #include statement to work. - * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ Index: doc/Encoding.3 ================================================================== --- doc/Encoding.3 +++ doc/Encoding.3 @@ -258,14 +258,10 @@ \fBTcl_WinUtfToTChar\fR and \fBTcl_WinTCharToUtf\fR are Windows-only convenience functions for converting between UTF-8 and Windows strings based on the TCHAR type which is by convention a Unicode character on Windows NT. -These functions are essentially wrappers around -\fBTcl_UtfToExternalDString\fR and -\fBTcl_ExternalToUtfDString\fR that convert to and from the -Unicode encoding. .PP \fBTcl_GetEncodingName\fR is roughly the inverse of \fBTcl_GetEncoding\fR. Given an \fIencoding\fR, the return value is the \fIname\fR argument that was used to create the encoding. The string returned by \fBTcl_GetEncodingName\fR is only guaranteed to persist until the Index: doc/GetInt.3 ================================================================== --- doc/GetInt.3 +++ doc/GetInt.3 @@ -62,13 +62,16 @@ if the first such characters are .QW \fB0o\fR then \fIsrc\fR is expected to be in octal form; otherwise, if the first such characters are .QW \fB0b\fR +then \fIsrc\fR is expected to be in binary form; otherwise, +if the first such character is +.QW \fB0\fR then \fIsrc\fR -is expected to be in binary form; otherwise, \fIsrc\fR is -expected to be in decimal form. +is expected to be in octal form; otherwise, \fIsrc\fR +is expected to be in decimal form. .PP \fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point number, which is: white space; a sign; a sequence of digits; a decimal point .QW \fB.\fR ; Index: doc/Interp.3 ================================================================== --- doc/Interp.3 +++ doc/Interp.3 @@ -31,10 +31,23 @@ other routines in the Tcl interface. Accessing fields directly through the pointer as described below is no longer supported. The supported public routines \fBTcl_SetResult\fR, \fBTcl_GetResult\fR, \fBTcl_SetErrorLine\fR, \fBTcl_GetErrorLine\fR must be used instead. .PP +For legacy programs and extensions no longer being maintained, compiles +against the Tcl 8.6 header files are only possible with the compiler +directives +.CS +#define USE_INTERP_RESULT +.CE +and/or +.CS +#define USE_INTERP_ERRORLINE +.CE +depending on which fields of the \fBTcl_Interp\fR struct are accessed. +These directives may be embedded in code or supplied via compiler options. +.PP The \fIresult\fR and \fIfreeProc\fR fields are used to return results or error messages from commands. This information is returned by command procedures back to \fBTcl_Eval\fR, and by \fBTcl_Eval\fR back to its callers. The \fIresult\fR field points to the string that represents the @@ -86,11 +99,11 @@ and \fIinterp->freeProc\fR just before calling the command procedure for 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 pointed to by \fIinterp->result\fR. .PP Index: doc/Object.3 ================================================================== --- doc/Object.3 +++ doc/Object.3 @@ -255,11 +255,11 @@ .PP The \fBincr\fR command first gets an integer from \fIx\fR's value by calling \fBTcl_GetIntFromObj\fR. This procedure checks whether the value is already an integer value. Since it is not, it converts the value -by setting the value's \fIinternalRep.longValue\fR member +by setting the value's internal representation to the integer \fB123\fR and setting the value's \fItypePtr\fR to point to the integer Tcl_ObjType structure. Both representations are now valid. \fBincr\fR increments the value's integer internal representation Index: doc/SetResult.3 ================================================================== --- doc/SetResult.3 +++ doc/SetResult.3 @@ -195,10 +195,23 @@ It frees up the memory associated with \fIinterp\fR's result. It also sets \fIinterp->freeProc\fR to zero, but does not change \fIinterp->result\fR or clear error state. \fBTcl_FreeResult\fR is most commonly used when a procedure is about to replace one result value with another. +.SS "DIRECT ACCESS TO INTERP->RESULT" +.PP +It used to be legal for programs to +directly read and write \fIinterp->result\fR +to manipulate the interpreter result. The Tcl headers no longer +permit this access by default, and C code still doing this must +be updated to use supported routines \fBTcl_GetObjResult\fR, +\fBTcl_GetStringResult\fR, \fBTcl_SetObjResult\fR, and \fBTcl_SetResult\fR. +As a migration aid, access can be restored with the compiler directive +.CS +#define USE_INTERP_RESULT +.CE +but this is meant only to offer life support to otherwise dead code. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP \fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how the Tcl system is to manage the storage for the \fIresult\fR argument. If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called Index: doc/ToUpper.3 ================================================================== --- doc/ToUpper.3 +++ doc/ToUpper.3 @@ -31,11 +31,11 @@ int \fBTcl_UtfToTitle\fR(\fIstr\fR) .SH ARGUMENTS .AS char *str in/out .AP int ch in -The Tcl_UniChar to be converted. +The Unicode character to be converted. .AP char *str in/out Pointer to UTF-8 string to be converted in place. .BE .SH DESCRIPTION Index: doc/UniCharIsAlpha.3 ================================================================== --- doc/UniCharIsAlpha.3 +++ doc/UniCharIsAlpha.3 @@ -46,23 +46,20 @@ int \fBTcl_UniCharIsWordChar\fR(\fIch\fR) .SH ARGUMENTS .AS int ch .AP int ch in -The Tcl_UniChar to be examined. +The Unicode character to be examined. .BE .SH DESCRIPTION .PP -All of the routines described examine Tcl_UniChars and return a +All of the routines described examine Unicode characters and return a boolean value. A non-zero return value means that the character does belong to the character class associated with the called routine. The rest of this document just describes the character classes associated with the various routines. -.PP -Note: A Tcl_UniChar is a Unicode character represented as an unsigned, -fixed-size quantity. .SH "CHARACTER CLASSES" .PP \fBTcl_UniCharIsAlnum\fR tests if the character is an alphanumeric Unicode character. .PP Index: doc/Utf.3 ================================================================== --- doc/Utf.3 +++ doc/Utf.3 @@ -75,11 +75,11 @@ .AS "const Tcl_UniChar" *uniPattern in/out .AP char *buf out Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most \fBTCL_UTF_MAX\fR bytes are stored in the buffer. .AP int ch in -The Tcl_UniChar to be converted or examined. +The Unicode character to be converted or examined. .AP Tcl_UniChar *chPtr out Filled with the Tcl_UniChar represented by the head of the UTF-8 string. .AP "const char" *src in Pointer to a UTF-8 string. .AP "const char" *cs in Index: doc/expr.n ================================================================== --- doc/expr.n +++ doc/expr.n @@ -48,11 +48,13 @@ ignored. An integer operand may be specified in decimal (the normal case, the optional first two characters are \fB0d\fR), binary (the first two characters are \fB0b\fR), octal (the first two characters are \fB0o\fR), or hexadecimal -(the first two characters are \fB0x\fR) form. +(the first two characters are \fB0x\fR) form. For +compatibility with older Tcl releases, an operand that begins with \fB0\fR is +interpreted as an octal integer even if the second character is not \fBo\fR. A floating-point number may be specified in any of several common decimal formats, and may use the decimal point \fB.\fR, \fBe\fR or \fBE\fR for scientific notation, and the sign characters \fB+\fR and \fB\-\fR. The following are all valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16. Index: doc/format.n ================================================================== --- doc/format.n +++ doc/format.n @@ -81,11 +81,11 @@ \fB0\fR 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. For \fBb\fR conversions, \fB0b\fR will be added to the beginning of the result unless it is zero. @@ -169,11 +169,11 @@ for \fBx\fR and .QW 0123456789ABCDEF 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. .TP 10 \fBs\fR Index: doc/scan.n ================================================================== --- doc/scan.n +++ doc/scan.n @@ -222,14 +222,16 @@ .CS set string "#08D03F" \fBscan\fR $string "#%2x%2x%2x" r g b .CE .PP -Parse a \fIHH:MM\fR time string: +Parse a \fIHH:MM\fR time string, noting that this avoids problems with +octal numbers by forcing interpretation as decimals (if we did not +care, we would use the \fB%i\fR conversion instead): .PP .CS -set string "08:08" +set string "08:08" ;# *Not* octal! if {[\fBscan\fR $string "%d:%d" hours minutes] != 2} { error "not a valid time string" } # We have to understand numeric ranges ourselves... if {$minutes < 0 || $minutes > 59} { Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -30,11 +30,11 @@ declare 0 { int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, 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) } declare 2 { TCL_NORETURN void Tcl_Panic(const char *format, ...) @@ -152,11 +152,11 @@ int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } 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) } declare 38 { @@ -283,11 +283,11 @@ int Tcl_AsyncReady(void) } 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 { int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, const char *optionList) @@ -304,11 +304,11 @@ } 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) } declare 85 { @@ -316,11 +316,11 @@ int flags) } 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, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]) @@ -350,11 +350,11 @@ void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData) } 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) } declare 96 { @@ -459,19 +459,18 @@ } 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) } -# This is obsolete, use Tcl_FSEvalFile declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } declare 131 { int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) @@ -527,16 +526,16 @@ declare 147 { void Tcl_FreeResult(Tcl_Interp *interp) } 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 { ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr) @@ -557,11 +556,11 @@ } 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, const char *optionName, Tcl_DString *dsPtr) } @@ -571,18 +570,18 @@ declare 159 { int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, 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) } declare 164 { @@ -621,18 +620,18 @@ } 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 { int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) } @@ -661,11 +660,11 @@ declare 185 { int Tcl_IsSafe(Tcl_Interp *interp) } # 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 { int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr, int type) @@ -684,11 +683,11 @@ } 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) } declare 194 { @@ -702,11 +701,11 @@ Tcl_Obj *Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags) } 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 { Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions) @@ -728,11 +727,11 @@ } 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) } declare 206 { @@ -764,11 +763,11 @@ int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern) } 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) } declare 217 { @@ -778,12 +777,11 @@ int Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } -# Obsolete -declare 220 { +declare 220 {deprecated {}} { int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) } declare 221 { int Tcl_ServiceAll(void) } @@ -835,43 +833,42 @@ } 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, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } declare 245 { int Tcl_StringMatch(const char *str, const char *pattern) } -# Obsolete -declare 246 { +declare 246 {deprecated {}} { int Tcl_TellOld(Tcl_Channel chan) } declare 247 { int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) @@ -943,51 +940,51 @@ int Tcl_DumpActiveMemory(const char *fileName) } declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } -declare 267 { +declare 267 {deprecated {see TIP #422}} { void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) } -declare 268 { +declare 268 {deprecated {see TIP #422}} { void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) } declare 269 { char *Tcl_HashStats(Tcl_HashTable *tablePtr) } 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) } declare 273 { int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, const char *version) } # 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 { +declare 275 {deprecated {see TIP #422}} { void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) } -declare 276 { +declare 276 {deprecated {see TIP #422}} { int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) } declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -declare 278 { +declare 278 {deprecated {see TIP #422}} { TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) } declare 279 { void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type) } @@ -1085,11 +1082,11 @@ } 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) } declare 304 { @@ -1161,29 +1158,29 @@ } 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) } 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, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, @@ -1212,14 +1209,14 @@ int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) } 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 { void Tcl_AlertNotifier(ClientData clientData) } @@ -1264,11 +1261,11 @@ } 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) } declare 358 { void Tcl_FreeParse(Tcl_Parse *parsePtr) @@ -1277,11 +1274,11 @@ void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, int length) } 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, int nested, Tcl_Parse *parsePtr) } @@ -1290,11 +1287,11 @@ Tcl_Parse *parsePtr) } 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, Tcl_Parse *parsePtr, int append) } @@ -1406,11 +1403,11 @@ } 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( const Tcl_ChannelType *chanTypePtr) } @@ -1546,16 +1543,16 @@ declare 434 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } # 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) } # TIP#36 (better access to 'subst') dkf declare 437 { Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -50,17 +50,17 @@ * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) * tools/tcl.hpj.in (not patchlevel, for windows installer) */ -#define TCL_MAJOR_VERSION 9 -#define TCL_MINOR_VERSION 0 +#define TCL_MAJOR_VERSION 8 +#define TCL_MINOR_VERSION 7 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 0 +#define TCL_RELEASE_SERIAL 2 -#define TCL_VERSION "9.0" -#define TCL_PATCH_LEVEL "9.0a0" +#define TCL_VERSION "8.7" +#define TCL_PATCH_LEVEL "8.7a2" #if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED) /* *---------------------------------------------------------------------------- * The following definitions set up the proper options for Windows compilers. @@ -135,11 +135,11 @@ * * New code should just directly be written to use stdarg.h conventions. */ #include -#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) #endif /* !TCL_NO_DEPRECATED */ #if defined(__GNUC__) && (__GNUC__ > 2) @@ -252,51 +252,32 @@ * for compilers written in the pre-prototype era of 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 * ANSI C features. */ #ifndef INLINE # define INLINE #endif - -#ifdef NO_CONST -# ifndef const -# define const -# endif -#endif #ifndef CONST # define CONST const #endif - -#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 +#define CONST84 const +#define CONST84_RETURN const + +#endif /* !TCL_NO_DEPRECATED */ #ifndef CONST86 -# define CONST86 CONST84 +# define CONST86 const #endif /* * Make sure EXTERN isn't defined elsewhere. */ @@ -316,10 +297,11 @@ * The following code is copied from winnt.h. If we don't replicate it here, * then can't be included after tcl.h, since tcl.h also defines * 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 typedef char CHAR; typedef short SHORT; @@ -331,27 +313,20 @@ * Macro to use instead of "void" for arguments that must have type "void *" * in ANSI C; maps them to type "char *" in non-ANSI systems. */ #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 /* * Darwin specific configure overrides (to support fat compiles, where @@ -490,11 +465,43 @@ * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc. * Instead, they set a Tcl_Obj member in the "real" structure that can be * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ -typedef struct Tcl_Interp Tcl_Interp; +typedef struct Tcl_Interp +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +{ + /* TIP #330: Strongly discourage extensions from using the string + * result. */ +#ifdef USE_INTERP_RESULT + char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); + /* If the last command returned a string + * result, this points to it. */ + void (*freeProc) (char *blockPtr) + TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); + /* Zero means the string result is statically + * allocated. TCL_DYNAMIC means it was + * allocated with ckalloc and should be freed + * with ckfree. Other values give the address + * of function to invoke to free the result. + * Tcl_Eval must free it before executing next + * command. */ +#else + char *resultDontUse; /* Don't use in extensions! */ + void (*freeProcDontUse) (char *); /* Don't use in extensions! */ +#endif +#ifdef USE_INTERP_ERRORLINE + int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); + /* When TCL_ERROR is returned, this gives the + * line number within the command where the + * error occurred (1 if first line). */ +#else + int errorLineDontUse; /* Don't use in extensions! */ +#endif +} +#endif /* !TCL_NO_DEPRECATED */ +Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; typedef struct Tcl_Command_ *Tcl_Command; @@ -639,10 +646,14 @@ #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#define TCL_RESULT_SIZE 200 +#endif + /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): */ @@ -653,10 +664,11 @@ /* * 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; typedef struct Tcl_Value { @@ -664,10 +676,14 @@ * or both. */ long intValue; /* Integer 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 * reference to Tcl_Obj is encountered in the function types declared below. */ @@ -684,14 +700,14 @@ int code); 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); typedef void (Tcl_CmdObjTraceDeleteProc) (ClientData clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, @@ -724,11 +740,11 @@ char *address, int port); 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, ClientData clientData); typedef void (Tcl_DeleteFileHandlerProc) (int fd); @@ -823,15 +839,24 @@ void Tcl_DecrRefCount(Tcl_Obj *objPtr); int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- - * The following type contains the state needed by Tcl_SaveResult. It - * is typically allocated on the stack. + * The following structure contains the state needed by Tcl_SaveResult. No-one + * outside of Tcl should access any of these fields. This structure is + * typically allocated on the stack. */ -typedef Tcl_Obj *Tcl_SavedResult; +typedef struct Tcl_SavedResult { + char *result; + Tcl_FreeProc *freeProc; + Tcl_Obj *objResultPtr; + char *appendResult; + int appendAvl; + int appendUsed; + char resultSpace[200+1]; +} Tcl_SavedResult; /* *---------------------------------------------------------------------------- * The following definitions support Tcl's namespace facility. Note: the first * five fields must match exactly the fields in a Namespace structure (see @@ -952,11 +977,11 @@ * small. */ } 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 */ /* * Definitions for the maximum number of digits of precision that may be @@ -1080,11 +1105,11 @@ * always parsed whenever the part2 is NULL. (This is to avoid a common error * when converting code to use the new object based APIs and forgetting to * 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 */ /* * Types for linked variables: @@ -1433,18 +1458,18 @@ typedef int (Tcl_DriverClose2Proc) (ClientData instanceData, Tcl_Interp *interp, int flags); 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, int direction, ClientData *handlePtr); typedef int (Tcl_DriverFlushProc) (ClientData instanceData); @@ -1933,11 +1958,11 @@ * the operator, then TCL_TOKEN_SUB_EXPR tokens * for the left then the right operands. * 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 * operands. NumComponents is always 0. * TCL_TOKEN_EXPAND_WORD - This token is just like TCL_TOKEN_WORD except @@ -2512,19 +2537,13 @@ # define Tcl_NewByteArrayObj(bytes, len) \ Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__) # undef Tcl_NewDoubleObj # define Tcl_NewDoubleObj(val) \ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) -# undef Tcl_NewIntObj -# define Tcl_NewIntObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewListObj # define Tcl_NewListObj(objc, objv) \ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) -# undef Tcl_NewLongObj -# define Tcl_NewLongObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewObj # define Tcl_NewObj() \ Tcl_DbNewObj(__FILE__, __LINE__) # undef Tcl_NewStringObj # define Tcl_NewStringObj(bytes, len) \ @@ -2583,14 +2602,14 @@ /* *---------------------------------------------------------------------------- * 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 # define Tcl_Ckfree Tcl_Free # define Tcl_Ckrealloc Tcl_Realloc Index: generic/tclAssembly.c ================================================================== --- generic/tclAssembly.c +++ generic/tclAssembly.c @@ -4264,11 +4264,11 @@ lineNo = Tcl_NewIntObj(bbPtr->startLine); Tcl_IncrRefCount(lineNo); Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { - TclSetLongObj(lineNo, bbPtr->successor1->startLine); + TclSetIntObj(lineNo, bbPtr->successor1->startLine); Tcl_AppendObjToErrorInfo(interp, lineNo); } else { Tcl_AddErrorInfo(interp, "end of assembly code"); } Tcl_DecrRefCount(lineNo); Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -116,10 +116,12 @@ static Tcl_ObjCmdProc ExprDoubleFunc; static Tcl_ObjCmdProc ExprEntierFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; +static Tcl_ObjCmdProc ExprMaxFunc; +static Tcl_ObjCmdProc ExprMinFunc; static Tcl_ObjCmdProc ExprRandFunc; static Tcl_ObjCmdProc ExprRoundFunc; static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; @@ -128,12 +130,14 @@ int actual, Tcl_Obj *const *objv); 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); static void TEOV_SwitchVarFrame(Tcl_Interp *interp); static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, @@ -201,11 +205,11 @@ */ {"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}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, @@ -319,10 +323,12 @@ { "hypot", ExprBinaryFunc, (ClientData) hypot }, { "int", ExprIntFunc, NULL }, { "isqrt", ExprIsqrtFunc, NULL }, { "log", ExprUnaryFunc, (ClientData) log }, { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "max", ExprMaxFunc, NULL }, + { "min", ExprMinFunc, NULL }, { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, { "sin", ExprUnaryFunc, (ClientData) sin }, { "sinh", ExprUnaryFunc, (ClientData) sinh }, @@ -508,16 +514,17 @@ */ iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; - iPtr->legacyResult = NULL; - /* Special invalid value: Any attempt to free the legacy result - * will cause a crash. */ - iPtr->legacyFreeProc = (void (*) (void))-1; +#ifdef TCL_NO_DEPRECATED + iPtr->result = &tclEmptyString; +#else + iPtr->result = iPtr->resultSpace; +#endif + iPtr->freeProc = NULL; iPtr->errorLine = 0; - iPtr->stubTable = &tclStubs; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); iPtr->globalNsPtr = NULL; iPtr->hiddenCmdTablePtr = NULL; @@ -570,10 +577,16 @@ iPtr->returnLevel = 1; iPtr->returnCode = TCL_OK; iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; + +#ifndef TCL_NO_DEPRECATED + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; +#endif Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; /* TIP #268 */ @@ -599,10 +612,13 @@ iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); +#ifndef TCL_NO_DEPRECATED + iPtr->resultSpace[0] = 0; +#endif iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ #ifdef TCL_INTERP_DEBUG_FRAME iPtr->flags |= INTERP_DEBUG_FRAME; @@ -708,10 +724,16 @@ statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); #endif /* TCL_COMPILE_STATS */ + /* + * Initialise the stub table pointer. + */ + + iPtr->stubTable = &tclStubs; + /* * Initialize the ensemble error message rewriting support. */ TclResetRewriteEnsemble(interp, 1); @@ -932,13 +954,15 @@ * Set up other variables such as tcl_version and tcl_library */ Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Tcl_TraceVar2(interp, "tcl_precision", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, NULL); +#endif /* !TCL_NO_DEPRECATED */ TclpSetVariables(interp); #ifdef TCL_THREADS /* * The existence of the "threaded" element of the tcl_platform array @@ -1503,10 +1527,11 @@ * Free up the result *after* deleting variables, since variable deletion * could have transferred ownership of the result string to Tcl. */ Tcl_FreeResult(interp); + iPtr->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); if (iPtr->errorCode) { Tcl_DecrRefCount(iPtr->errorCode); @@ -1524,10 +1549,16 @@ Tcl_DecrRefCount(iPtr->innerLiteral); Tcl_DecrRefCount(iPtr->innerContext); if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } +#ifndef TCL_NO_DEPRECATED + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + } +#endif TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); } if (iPtr->execEnvPtr != NULL) { @@ -2073,17 +2104,17 @@ tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - if (isNew || deleted) { + if (isNew || deleted) { /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; - } + } /* An existing command conflicts. Try to delete it.. */ cmdPtr = Tcl_GetHashValue(hPtr); /* @@ -2220,68 +2251,86 @@ * the global namespace. */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ ClientData clientData, /* Arbitrary value to pass to object * function. */ - Tcl_CmdDeleteProc *deleteProc) + Tcl_CmdDeleteProc *deleteProc /* If not NULL, gives a function to call when * this command is deleted. */ +) { Interp *iPtr = (Interp *) interp; - ImportRef *oldRefPtr = NULL; Namespace *nsPtr; - Command *cmdPtr; - Tcl_HashEntry *hPtr; const char *tail; - int isNew = 0, deleted = 0; - ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Don't create any new commands; * it's not safe to muck with the interpreter anymore. */ - return (Tcl_Command) NULL; } + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + Namespace *dummy1, *dummy2; + + TclGetNamespaceForQualName(interp, cmdName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, + proc, clientData, deleteProc); +} + +Tcl_Command +TclCreateObjCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, /* Name of command, without any namespace components */ + Tcl_Namespace *namespace, /* The namespace to create the command in */ + Tcl_ObjCmdProc *proc, /* Object-based function to associate with + * name. */ + ClientData clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc + /* If not NULL, gives a function to call when + * this command is deleted. */ +) { + int deleted = 0, isNew = 0; + Command *cmdPtr; + ImportRef *oldRefPtr = NULL; + ImportedCmdData *dataPtr; + Tcl_HashEntry *hPtr; + Namespace *nsPtr = (Namespace *) namespace; /* * If the command name we seek to create already exists, we need to * delete that first. That can be tricky in the presence of traces. * Loop until we no longer find an existing command in the way, or * until we've deleted one command and that didn't finish the job. */ - while (1) { - /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; - * otherwise, we always put it in the global namespace. - */ - - if (strstr(cmdName, "::") != NULL) { - Namespace *dummy1, *dummy2; - - TclGetNamespaceForQualName(interp, cmdName, NULL, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((nsPtr == NULL) || (tail == NULL)) { - return (Tcl_Command) NULL; - } - } else { - nsPtr = iPtr->globalNsPtr; - tail = cmdName; - } - - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - - if (isNew || deleted) { + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); + + if (isNew || deleted) { /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; - } + } + /* An existing command conflicts. Try to delete it.. */ cmdPtr = Tcl_GetHashValue(hPtr); /* @@ -2310,21 +2359,26 @@ cmdPtr->refCount++; if (cmdPtr->importRefPtr) { cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; } + + /* Make sure namespace doesn't get deallocated. */ + cmdPtr->nsPtr->refCount++; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + nsPtr = (Namespace *) TclEnsureNamespace(interp, + (Tcl_Namespace *)cmdPtr->nsPtr); + TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; } TclCleanupCommandMacro(cmdPtr); deleted = 1; } - if (!isNew) { /* * If the deletion callback recreated the command, just throw away * the new command (if we try to delete it again, we could get * stuck in an infinite loop). @@ -2342,11 +2396,11 @@ * Without invalidating a possible CmdName literal here explicitly, * such literals keep being reused while pointing to overhauled * commands. */ - TclInvalidateCmdLiteral(interp, tail, nsPtr); + TclInvalidateCmdLiteral(interp, cmdName, nsPtr); /* * The list of command exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we * need the info will be soon enough. @@ -2457,11 +2511,11 @@ * pointer to this function is stored as the Tcl_CmdProc in a Command * structure. It simply turns around and calls the object Tcl_ObjCmdProc * in the Command structure. * * Results: - * A standard Tcl result value. + * A standard Tcl string result value. * * Side effects: * Besides those side effects of the called Tcl_ObjCmdProc, * TclInvokeObjectCommand allocates and frees storage. * @@ -2497,10 +2551,17 @@ } else { result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, cmdPtr->objClientData, argc, objv); } + /* + * Move the interpreter's object result to the string result, then reset + * the object result. + */ + + (void) Tcl_GetStringResult(interp); + /* * Decrement the ref counts for the argument objects created above, then * free the objv array if malloc'ed storage was used. */ @@ -2565,26 +2626,26 @@ ((newName == NULL)||(*newName == '\0'))? "delete":"rename", oldName)); 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 * with Tcl_DeleteCommandFromToken, since we already have the command. */ 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 * create the containing namespaces just like Tcl_CreateCommand would. */ @@ -3091,10 +3152,12 @@ /* * Call trace functions for the command being deleted. Then delete its * traces. */ + + cmdPtr->nsPtr->refCount++; if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); @@ -3119,10 +3182,11 @@ * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. */ TclInvalidateNsCmdLookup(cmdPtr->nsPtr); + TclNsDecrRefCount(cmdPtr->nsPtr); /* * If the command being deleted has a compile function, increment the * interpreter's compileEpoch to invalidate its compiled code. This makes * sure that we don't later try to execute old code compiled with @@ -3456,10 +3520,11 @@ * invalidated if the number of arguments has changed. * *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) void Tcl_CreateMathFunc( Tcl_Interp *interp, /* Interpreter in which function is to be * available. */ const char *name, /* Name of function (e.g. "sin"). */ @@ -3506,11 +3571,11 @@ *---------------------------------------------------------------------- */ 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 */ Tcl_Obj *const *objv) /* Parameter vector */ { @@ -3551,10 +3616,11 @@ */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", -1)); + TclCheckBadOctal(interp, TclGetString(valuePtr)); ckfree(args); return TCL_ERROR; } /* @@ -3618,11 +3684,11 @@ /* * Return the result of the call. */ if (funcResult.type == TCL_INT) { - TclNewLongObj(valuePtr, funcResult.intValue); + TclNewIntObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); } else { return CheckDoubleResult(interp, funcResult.doubleValue); } @@ -3786,10 +3852,11 @@ Tcl_DecrRefCount(script); Tcl_RestoreInterpState(interp, state); return result; } +#endif /* !defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- * * TclInterpReady -- @@ -3800,11 +3867,11 @@ * Results: * The return value is TCL_OK if it the interpreter is ready, TCL_ERROR * otherwise. * * Side effects: - * The interpreter's result is cleared. + * The interpreters object and string results are cleared. * *---------------------------------------------------------------------- */ int @@ -3812,12 +3879,12 @@ Tcl_Interp *interp) { register Interp *iPtr = (Interp *) interp; /* - * Reset the interpreter's result and clear out any previous error - * information. + * Reset both the interpreter's string and object results and clear out + * any previous error information. */ Tcl_ResetResult(interp); /* @@ -4393,12 +4460,27 @@ int result, struct NRE_callback *rootPtr) /* All callbacks down to rootPtr not inclusive * are to be run. */ { + Interp *iPtr = (Interp *) interp; NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; + + /* + * If the interpreter has a non-empty string result, the result object is + * either empty or stale because some function set interp->result + * directly. If so, move the string result to the result object, then + * reset the string result. + * + * This only needs to be done for the first item in the list: all other + * are for NR function calls, and those are Tcl_Obj based. + */ + + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); + } while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); procPtr = callbackPtr->procPtr; TOP_CB(interp) = callbackPtr->nextPtr; @@ -4529,11 +4611,11 @@ if (result != TCL_OK) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } - if ((result != TCL_ERROR) && !allowExceptions) { + if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { ProcessUnexpectedResult(interp, result); result = TCL_ERROR; } } @@ -4710,11 +4792,11 @@ int objc, Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - size_t newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; const char *command = TclGetStringFromObj(commandPtr, &length); /* * Call trace functions. @@ -4853,10 +4935,11 @@ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, NULL, NULL); } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * * Tcl_EvalTokens -- * @@ -4900,10 +4983,11 @@ resPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resPtr); Tcl_ResetResult(interp); return resPtr; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * * Tcl_EvalEx, TclEvalEx -- @@ -5863,11 +5947,20 @@ Tcl_Eval( Tcl_Interp *interp, /* Token for command interpreter (returned by * previous call to Tcl_CreateInterp). */ const char *script) /* Pointer to TCL command to execute. */ { - return Tcl_EvalEx(interp, script, -1, 0); + int code = Tcl_EvalEx(interp, script, -1, 0); + + /* + * For backwards compatibility with old C code that predates the object + * system in Tcl 8.0, we have to mirror the object result back into the + * string result (some callers may expect it there). + */ + + (void) Tcl_GetStringResult(interp); + return code; } /* *---------------------------------------------------------------------- * @@ -6286,10 +6379,13 @@ } else { exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } } return result; } int @@ -6312,10 +6408,13 @@ exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* Discard the expression object. */ + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } } return result; } int @@ -6337,10 +6436,18 @@ Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + /* + * Move the interpreter's object result to the string result, then + * reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + } return result; } } /* @@ -6395,11 +6502,10 @@ return TCL_ERROR; } resultPtr = Tcl_NewBignumObj(&big); /* FALLTHROUGH */ } - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); break; @@ -6651,10 +6757,16 @@ if (code == TCL_OK) { Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); } } + + /* + * Force the string rep of the interp result. + */ + + (void) Tcl_GetStringResult(interp); return code; } /* *---------------------------------------------------------------------- @@ -6757,11 +6869,23 @@ * the error message in the interpreter's result. */ iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - iPtr->errorInfo = iPtr->objResultPtr; + if (iPtr->result[0] != 0) { + /* + * The interp's string result is set, apparently by some extension + * making a deprecated direct write to it. That extension may + * expect interp->result to continue to be set, so we'll take + * special pains to avoid clearing it, until we drop support for + * interp->result completely. + */ + + iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); + } else { + iPtr->errorInfo = iPtr->objResultPtr; + } Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); } } @@ -6835,11 +6959,11 @@ * Given a variable number of string arguments, concatenate them all * together and execute the result as a Tcl command. * * Results: * A standard Tcl return result. An error message or other result may be - * left in the interp. + * left in interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- @@ -7353,16 +7477,16 @@ if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } - if (type == TCL_NUMBER_LONG) { - long l = *((const long *) ptr); + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt l = *((const Tcl_WideInt *) ptr); - if (l > (long)0) { + if (l > (Tcl_WideInt)0) { goto unChanged; - } else if (l == (long)0) { + } else if (l == (Tcl_WideInt)0) { const char *string = objv[1]->bytes; if (string) { while (*string != '0') { if (*string == '-') { Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); @@ -7370,15 +7494,15 @@ } string++; } } goto unChanged; - } else if (l == LONG_MIN) { - TclInitBignumFromLong(&big, l); + } else if (l == LLONG_MIN) { + TclInitBignumFromWideInt(&big, l); goto tooLarge; } - Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l)); return TCL_OK; } if (type == TCL_NUMBER_DOUBLE) { double d = *((const double *) ptr); @@ -7398,26 +7522,10 @@ } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt w = *((const Tcl_WideInt *) ptr); - - if (w >= (Tcl_WideInt)0) { - goto unChanged; - } - if (w == LLONG_MIN) { - TclInitBignumFromWideInt(&big, w); - goto tooLarge; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); - return TCL_OK; - } -#endif - if (type == TCL_NUMBER_BIG) { if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: mp_neg(&big, &big); @@ -7609,10 +7717,75 @@ Tcl_DecrRefCount(objPtr); } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; } + +/* + * Common implmentation of max() and min(). + */ +static int +ExprMaxMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv, /* Actual parameter vector. */ + int op) /* Comparison direction */ +{ + Tcl_Obj *res; + double d; + int type, i; + ClientData ptr; + + if (objc < 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + res = objv[1]; + for (i = 1; i < objc; i++) { + if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + /* + * Get the error message for NaN. + */ + + Tcl_GetDoubleFromObj(interp, objv[i], &d); + return TCL_ERROR; + } + if (TclCompareTwoNumbers(objv[i], res) == op) { + res = objv[i]; + } + } + + Tcl_SetObjResult(interp, res); + return TCL_OK; +} + +static int +ExprMaxFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_GT); +} + +static int +ExprMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_LT); +} static int ExprRandFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the @@ -7633,11 +7806,11 @@ if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { iPtr->flags |= RAND_SEED_INITIALIZED; /* - * To ensure different seeds in different threads (bug #416643), + * To ensure different seeds in different threads (bug #416643), * take into consideration the thread this interp is running in. */ iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); @@ -8095,10 +8268,26 @@ * this command is deleted. */ { Command *cmdPtr = (Command *) Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); + cmdPtr->nreProc = nreProc; + return (Tcl_Command) cmdPtr; +} + +Tcl_Command +TclNRCreateCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc) { + Command *cmdPtr = (Command *) + TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); + cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; } /**************************************************************************** @@ -8883,48 +9072,35 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Command *cmdPtr; CoroutineData *corPtr; - const char *fullName, *procName; - Namespace *nsPtr, *altNsPtr, *cxtNsPtr; - Tcl_DString ds; + const char *procName, *simpleName; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr, + *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?"); return TCL_ERROR; } - /* - * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have - * something in tclUtil.c to find the FQ name. - */ - - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, inNsPtr, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); - return TCL_ERROR; - } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\" in non-global namespace with" - " name starting with \":\"", procName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } /* @@ -8932,20 +9108,13 @@ * struct and create the corresponding command. */ corPtr = ckalloc(sizeof(CoroutineData)); - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); - Tcl_DStringFree(&ds); + cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, + (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, + corPtr, DeleteCoroutine); corPtr->cmdPtr = cmdPtr; cmdPtr->refCount++; /* Index: generic/tclCmdAH.c ================================================================== --- generic/tclCmdAH.c +++ generic/tclCmdAH.c @@ -162,11 +162,11 @@ * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ int Tcl_CaseObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -2943,11 +2943,11 @@ Tcl_WideInt patWide, objWide; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; - SortStrCmpFn_t strCmpFn = strcmp; + SortStrCmpFn_t strCmpFn = TclUtfCmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", @@ -4261,11 +4261,11 @@ * "lsort" command. */ { int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(elemPtr1->collationKey.strValuePtr, + order = TclUtfCmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { Index: generic/tclCmdMZ.c ================================================================== --- generic/tclCmdMZ.c +++ generic/tclCmdMZ.c @@ -307,11 +307,11 @@ if (offset == 0) { eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') { + } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; } @@ -1214,17 +1214,26 @@ */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { + int fullchar; len = TclUtfToUniChar(stringPtr, &ch); + fullchar = ch; + +#if TCL_UTF_MAX == 4 + if (!len) { + len += TclUtfToUniChar(stringPtr, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif /* * Assume Tcl_UniChar is an integral type... */ - hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch), + hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(fullchar), &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); /* @@ -1594,13 +1603,10 @@ break; case STR_IS_DOUBLE: { /* TODO */ if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType) || -#ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || -#endif (objPtr->typePtr == &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { @@ -1631,13 +1637,10 @@ break; } goto failedIntParse; case STR_IS_ENTIER: if ((objPtr->typePtr == &tclIntType) || -#ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || -#endif (objPtr->typePtr == &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { @@ -1812,12 +1815,20 @@ } goto str_is_done; } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { + int fullchar; length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { + fullchar = ch; +#if TCL_UTF_MAX == 4 + if (!length2) { + length2 = TclUtfToUniChar(string1, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + if (!chcomp(fullchar)) { result = 0; break; } } } @@ -2874,11 +2885,10 @@ * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ - static int StringBytesCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -3528,11 +3538,11 @@ enum options { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); - strCmpFn_t strCmpFn = strcmp; + strCmpFn_t strCmpFn = TclUtfCmp; mode = OPT_EXACT; foundmode = 0; indexVarObj = NULL; matchVarObj = NULL; @@ -4291,11 +4301,11 @@ Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } info[0] = objv[i]; /* type */ - TclNewLongObj(info[1], code); /* returnCode */ + TclNewIntObj(info[1], code); /* returnCode */ if (info[2] == NULL) { /* errorCodePrefix */ TclNewObj(info[2]); } info[3] = objv[i+2]; /* bindVariables */ info[4] = objv[i+3]; /* script */ Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -423,15 +423,15 @@ * procs are redefined. */ Namespace *nsPtr; /* Namespace context in which this code was * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - size_t nsEpoch; /* Value of nsPtr->resolverEpoch when this + unsigned int nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - int refCount; /* Reference count: set 1 when created plus 1 + unsigned int refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ unsigned int flags; /* flags describing state for the codebyte. * this variable holds ORed values from the Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -51,11 +51,11 @@ /* 0 */ 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 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ @@ -157,12 +157,11 @@ /* 35 */ 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, int *intPtr); /* 38 */ @@ -261,11 +260,12 @@ /* 75 */ 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, const char *optionList); /* 79 */ @@ -278,11 +278,11 @@ /* 81 */ 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); /* 85 */ EXTERN int Tcl_ConvertCountedElement(const char *src, @@ -289,11 +289,11 @@ int length, char *dst, int flags); /* 86 */ 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, const char *targetCmd, int objc, Tcl_Obj *const objv[]); @@ -320,11 +320,12 @@ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData); /* 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); /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, @@ -410,13 +411,13 @@ /* 125 */ 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 */ EXTERN int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); @@ -467,17 +468,17 @@ EXTERN void Tcl_FreeResult(Tcl_Interp *interp); /* 148 */ 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, const char *name, Tcl_InterpDeleteProc **procPtr); @@ -492,11 +493,11 @@ /* 154 */ 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, Tcl_DString *dsPtr); /* 158 */ @@ -503,16 +504,16 @@ EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); /* 159 */ 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); /* 164 */ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); @@ -544,18 +545,17 @@ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName); /* 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); +EXTERN const 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, - int flags); +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); /* 178 */ EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp, @@ -576,11 +576,11 @@ /* 184 */ 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, char *addr, int type); /* Slot 188 is reserved */ @@ -589,11 +589,11 @@ /* 190 */ 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 */ EXTERN void Tcl_NotifyChannel(Tcl_Channel channel, int mask); /* 195 */ @@ -603,11 +603,11 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, 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, int permissions); /* 199 */ @@ -625,11 +625,11 @@ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst); /* 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); /* 206 */ EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead); @@ -655,12 +655,11 @@ /* 214 */ 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 */ EXTERN void Tcl_ResetResult(Tcl_Interp *interp); /* 218 */ @@ -667,11 +666,12 @@ EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ EXTERN int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr); /* 220 */ -EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); +TCL_DEPRECATED("") +int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); /* 221 */ EXTERN int Tcl_ServiceAll(void); /* 222 */ EXTERN int Tcl_ServiceEvent(int flags); /* 223 */ @@ -711,39 +711,39 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 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); +EXTERN const 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, - const char *newValue, int flags); +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, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 245 */ EXTERN int Tcl_StringMatch(const char *str, const char *pattern); /* 246 */ -EXTERN int Tcl_TellOld(Tcl_Channel chan); +TCL_DEPRECATED("") +int Tcl_TellOld(Tcl_Channel chan); /* 247 */ EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ @@ -810,44 +810,47 @@ /* 265 */ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); /* 267 */ -EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList); /* 268 */ -EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList); /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ -EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, - 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 */ -EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList); /* 276 */ -EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); +TCL_DEPRECATED("see TIP #422") +int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); /* 278 */ -EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); +TCL_DEPRECATED("see TIP #422") +TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); /* 279 */ EXTERN void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); /* 280 */ EXTERN void Tcl_InitMemory(Tcl_Interp *interp); @@ -908,11 +911,11 @@ /* 300 */ 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 */ EXTERN int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, @@ -967,24 +970,24 @@ /* 323 */ 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, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, @@ -1008,13 +1011,15 @@ /* 339 */ 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 */ EXTERN void Tcl_ServiceModeHook(int mode); /* 345 */ @@ -1045,11 +1050,12 @@ Tcl_DString *dsPtr); /* 356 */ 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); /* 359 */ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp, @@ -1057,11 +1063,11 @@ int length); /* 360 */ 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, Tcl_Parse *parsePtr); /* 362 */ @@ -1069,11 +1075,11 @@ int numBytes, Tcl_Parse *parsePtr); /* 363 */ 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, Tcl_Parse *parsePtr, int append); /* 365 */ @@ -1159,12 +1165,11 @@ /* 396 */ 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); /* 400 */ EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc( @@ -1266,17 +1271,19 @@ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ 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, int flags); /* 438 */ @@ -1841,11 +1848,11 @@ typedef struct TclStubs { int magic; 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 */ char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */ char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */ @@ -1892,11 +1899,11 @@ int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */ int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */ 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 */ CONST86 Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */ char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 41 */ @@ -1933,29 +1940,29 @@ void (*tcl_AsyncDelete) (Tcl_AsyncHandler async); /* 72 */ int (*tcl_AsyncInvoke) (Tcl_Interp *interp, int code); /* 73 */ 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 */ void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */ Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */ 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 */ Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ @@ -1983,12 +1990,12 @@ void (*tcl_DStringInit) (Tcl_DString *dsPtr); /* 122 */ void (*tcl_DStringResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 123 */ 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 */ void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ @@ -2004,25 +2011,25 @@ void (*tcl_Finalize) (void); /* 143 */ void (*tcl_FindExecutable) (const char *argv0); /* 144 */ 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 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ @@ -2038,41 +2045,41 @@ int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ 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 */ int (*tcl_Init) (Tcl_Interp *interp); /* 180 */ void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */ int (*tcl_InputBlocked) (Tcl_Channel chan); /* 182 */ 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 */ int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */ int (*tcl_RecordAndEvalObj) (Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags); /* 209 */ @@ -2079,16 +2086,16 @@ void (*tcl_RegisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 210 */ void (*tcl_RegisterObjType) (const Tcl_ObjType *typePtr); /* 211 */ 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 */ int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */ - int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ + TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */ void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */ int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */ @@ -2101,20 +2108,20 @@ void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */ int (*tcl_SetServiceMode) (int mode); /* 233 */ 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 */ - int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ + TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ @@ -2131,22 +2138,22 @@ ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ - void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ - void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ - CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */ - CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ - CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ + 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 */ - void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ - int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ + 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 */ - TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ + TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */ void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */ int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */ Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */ @@ -2166,11 +2173,11 @@ void (*tcl_FinalizeThread) (void); /* 297 */ void (*tcl_FinalizeNotifier) (ClientData clientData); /* 298 */ 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 */ Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 306 */ ClientData (*tcl_InitNotifier) (void); /* 307 */ @@ -2189,28 +2196,28 @@ Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */ 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 */ int (*tcl_UtfToTitle) (char *src); /* 335 */ int (*tcl_UtfToUniChar) (const char *src, Tcl_UniChar *chPtr); /* 336 */ int (*tcl_UtfToUpper) (char *src); /* 337 */ 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 */ int (*tcl_UniCharIsAlpha) (int ch); /* 346 */ int (*tcl_UniCharIsDigit) (int ch); /* 347 */ @@ -2221,17 +2228,17 @@ int (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */ int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */ 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 */ int (*tcl_Access) (const char *path, int mode); /* 367 */ int (*tcl_Stat) (const char *path, struct stat *bufPtr); /* 368 */ @@ -2262,11 +2269,11 @@ int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); /* 393 */ int (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, int bytesToRead); /* 394 */ 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 */ Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) (const Tcl_ChannelType *chanTypePtr); /* 402 */ Tcl_DriverInputProc * (*tcl_ChannelInputProc) (const Tcl_ChannelType *chanTypePtr); /* 403 */ @@ -2299,12 +2306,12 @@ char * (*tcl_AttemptRealloc) (char *ptr, unsigned int size); /* 430 */ char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */ 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 */ int (*tcl_FSCopyFile) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); /* 440 */ int (*tcl_FSCopyDirectory) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); /* 441 */ @@ -3886,24 +3893,24 @@ #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) #undef Tcl_SaveResult #define Tcl_SaveResult(interp, statePtr) \ do { \ - *(statePtr) = Tcl_GetObjResult(interp); \ - Tcl_IncrRefCount(*(statePtr)); \ + (statePtr)->objResultPtr = Tcl_GetObjResult(interp); \ + Tcl_IncrRefCount((statePtr)->objResultPtr); \ Tcl_SetObjResult(interp, Tcl_NewObj()); \ } while(0) #undef Tcl_RestoreResult #define Tcl_RestoreResult(interp, statePtr) \ do { \ Tcl_ResetResult(interp); \ - Tcl_SetObjResult(interp, *(statePtr)); \ - Tcl_DecrRefCount(*(statePtr)); \ + Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \ + Tcl_DecrRefCount((statePtr)->objResultPtr); \ } while(0) #undef Tcl_DiscardResult #define Tcl_DiscardResult(statePtr) \ - Tcl_DecrRefCount(*(statePtr)) + Tcl_DecrRefCount((statePtr)->objResultPtr) #undef Tcl_SetResult #define Tcl_SetResult(interp, result, freeProc) \ do { \ char *__result = result; \ Tcl_FreeProc *__freeProc = freeProc; \ @@ -3925,24 +3932,18 @@ * Win64 signature. Cygwin64 stubbed extensions cannot use those stub * entries any more, they should use the 64-bit alternatives where * possible. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ -# undef Tcl_DbNewLongObj # undef Tcl_GetLongFromObj -# undef Tcl_NewLongObj -# undef Tcl_SetLongObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj # undef Tcl_UniCharNcmp # undef Tcl_UtfNcmp # undef Tcl_UtfNcasecmp # undef Tcl_UniCharNcasecmp -# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj) # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) -# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj) -# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ int intValue; int result = tclStubsPtr->tcl_ExprLong(interp, string, (long *)&intValue); if (result == TCL_OK) *ptr = (long)intValue; @@ -3964,10 +3965,21 @@ # define Tcl_UniCharNcasecmp(ucs,uct,n) \ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n)) # endif #endif +#undef Tcl_NewLongObj +#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value)) +#undef Tcl_NewIntObj +#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) +#undef Tcl_DbNewLongObj +#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) +#undef Tcl_SetIntObj +#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (int)(value)) +#undef Tcl_SetLongObj +#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (long)(value)) + /* * Deprecated Tcl procedures: */ #undef Tcl_EvalObj Index: generic/tclDictObj.c ================================================================== --- generic/tclDictObj.c +++ generic/tclDictObj.c @@ -485,19 +485,18 @@ static void UpdateStringOfDict( Tcl_Obj *dictPtr) { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; const char *elem; char *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * This field is the most useful one in the whole hash structure, and it * is not exposed by any API function... */ @@ -515,14 +514,12 @@ * Pass 1: estimate space, gather flags. */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (numElems > maxFlags) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; inextPtr) { /* * Assume that cPtr is never NULL since we know the number of array * elements already. Index: generic/tclDisassemble.c ================================================================== --- generic/tclDisassemble.c +++ generic/tclDisassemble.c @@ -252,11 +252,11 @@ int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_Obj *bufferObj, *fileObj; TclNewObj(bufferObj); - if (codePtr->refCount <= 0) { + if (!codePtr->refCount) { return bufferObj; /* Already freed. */ } codeStart = codePtr->codeStart; codeLimit = codeStart + codePtr->numCodeBytes; @@ -310,11 +310,11 @@ if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; Tcl_AppendPrintfToObj(bufferObj, - " Proc %p, refCt %d, args %d, compiled locals %d\n", + " Proc %p, refCt %u, args %d, compiled locals %d\n", procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; @@ -795,11 +795,11 @@ unsigned char inst) { Tcl_Obj *objPtr = Tcl_NewObj(); objPtr->typePtr = &tclInstNameType; - objPtr->internalRep.longValue = (long) inst; + objPtr->internalRep.wideValue = (long) inst; objPtr->bytes = NULL; return objPtr; } @@ -815,19 +815,19 @@ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { - int inst = objPtr->internalRep.longValue; + int inst = objPtr->internalRep.wideValue; char *s, buf[20]; int len; if ((inst < 0) || (inst > LAST_INST_OPCODE)) { sprintf(buf, "inst_%d", inst); s = buf; } else { - s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + s = (char *) tclInstructionTable[objPtr->internalRep.wideValue].name; } len = strlen(s); objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, s, len + 1); objPtr->length = len; Index: generic/tclEncoding.c ================================================================== --- generic/tclEncoding.c +++ generic/tclEncoding.c @@ -16,11 +16,11 @@ /* * The following data structure represents an encoding, which describes how to * convert between various character sets and UTF-8. */ -typedef struct Encoding { +typedef struct { char *name; /* Name of encoding. Malloced because (1) hash * table entry that owns this encoding may be * freed prior to this encoding being freed, * (2) string passed in the Tcl_EncodingType * structure may not be persistent. */ @@ -55,11 +55,11 @@ * table-driven encoding created by LoadTableEncoding(). It maps between * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only) * encoding. */ -typedef struct TableEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ char prefixBytes[256]; /* If a byte in the input stream is a lead * byte for a 2-byte sequence, the @@ -89,20 +89,20 @@ * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven" * does not necessarily mean that the ESCAPE character is the character used * for switching character sets. */ -typedef struct EscapeSubTable { +typedef struct { unsigned sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ char name[32]; /* Name for encoding. */ Encoding *encodingPtr; /* Encoding loaded using above name, or NULL * if this sub-encoding has not been needed * yet. */ } EscapeSubTable; -typedef struct EscapeEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ unsigned initLen; /* Length of following string. */ char init[16]; /* String to emit or expect before first char @@ -691,10 +691,11 @@ * None. * *------------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 const char * Tcl_GetDefaultEncodingDir(void) { int numDirs; Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath(); @@ -734,10 +735,11 @@ searchPath = Tcl_DuplicateObj(searchPath); Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); Tcl_SetEncodingSearchPath(searchPath); } +#endif /* *------------------------------------------------------------------------- * * Tcl_GetEncoding -- @@ -3607,11 +3609,11 @@ */ static void InitializeEncodingSearchPath( char **valuePtr, - size_t *lengthPtr, + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; int i, numDirs; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; Index: generic/tclEnsemble.c ================================================================== --- generic/tclEnsemble.c +++ generic/tclEnsemble.c @@ -90,11 +90,11 @@ * The internal rep for caching ensemble subcommand lookups and * spell corrections. */ typedef struct { - size_t epoch; /* Used to confirm when the data in this + unsigned int epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ Command *token; /* Reference to the command for which this * structure is a cache of the resolution. */ Tcl_Obj *fix; /* Corrected spelling, if needed. */ @@ -144,14 +144,16 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Namespace *namespacePtr; - Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr, + *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; Tcl_Command token; Tcl_DictSearch search; Tcl_Obj *listObj; + const char *simpleName; int index, done; if (nsPtr == NULL || nsPtr->flags & NS_DYING) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -193,17 +195,12 @@ return TCL_ERROR; } objv += 2; objc -= 2; - /* - * Work out what name to use for the command to create. If supplied, - * it is either fully specified or relative to the current namespace. - * If not supplied, it is exactly the name of the current namespace. - */ - - name = nsPtr->fullName; + name = nsPtr->name; + cxtPtr = (Namespace *) nsPtr->parentPtr; /* * Parse the option list, applying type checks as we go. Note that we * are not incrementing any reference counts in the objects at this * stage, so the presence of an option multiple times won't cause any @@ -219,10 +216,11 @@ return TCL_ERROR; } switch ((enum EnsCreateOpts) index) { case CRT_CMD: name = TclGetString(objv[1]); + cxtPtr = nsPtr; continue; case CRT_SUBCMDS: if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); @@ -335,19 +333,24 @@ unknownObj = (len > 0 ? objv[1] : NULL); continue; } } + TclGetNamespaceForQualName(interp, name, cxtPtr, + TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr, + &simpleName); + /* * Create the ensemble. Note that this might delete another ensemble * linked to the same namespace, so we must be careful. However, we * should be OK because we only link the namespace into the list once * we've created it (and after any deletions have occurred.) */ - token = Tcl_CreateEnsemble(interp, name, NULL, - (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); + token = TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, + (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); Tcl_SetEnsembleParameterList(interp, token, paramObj); @@ -634,52 +637,42 @@ } /* *---------------------------------------------------------------------- * - * Tcl_CreateEnsemble -- - * - * Create a simple ensemble attached to the given namespace. - * - * Results: - * The token for the command created. - * - * Side effects: - * The ensemble is created and marked for compilation. + * TclCreateEnsembleInNs -- + * + * Like Tcl_CreateEnsemble, but additionally accepts as an argument the + * name of the namespace to create the command in. * *---------------------------------------------------------------------- */ Tcl_Command -Tcl_CreateEnsemble( +TclCreateEnsembleInNs( Tcl_Interp *interp, - const char *name, - Tcl_Namespace *namespacePtr, - int flags) -{ - Namespace *nsPtr = (Namespace *) namespacePtr; - EnsembleConfig *ensemblePtr = ckalloc(sizeof(EnsembleConfig)); - Tcl_Obj *nameObj = NULL; - - if (nsPtr == NULL) { - nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - } - - /* - * Make the name of the ensemble into a fully qualified name. This might - * allocate a temporary object. - */ - - if (!(name[0] == ':' && name[1] == ':')) { - nameObj = NewNsObj((Tcl_Namespace *) nsPtr); - if (nsPtr->parentPtr == NULL) { - Tcl_AppendStringsToObj(nameObj, name, NULL); - } else { - Tcl_AppendStringsToObj(nameObj, "::", name, NULL); - } - Tcl_IncrRefCount(nameObj); - name = TclGetString(nameObj); + + const char *name, /* Simple name of command to create (no */ + /* namespace components). */ + Tcl_Namespace /* Name of namespace to create the command in. */ + *nameNsPtr, + Tcl_Namespace + *ensembleNsPtr, /* Name of the namespace for the ensemble. */ + int flags + ) +{ + Namespace *nsPtr = (Namespace *) ensembleNsPtr; + EnsembleConfig *ensemblePtr; + Tcl_Command token; + + ensemblePtr = ckalloc(sizeof(EnsembleConfig)); + token = TclNRCreateCommandInNs(interp, name, + (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd, + NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); + if (token == NULL) { + ckfree(ensemblePtr); + return NULL; } ensemblePtr->nsPtr = nsPtr; ensemblePtr->epoch = 0; Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); @@ -688,13 +681,11 @@ ensemblePtr->subcommandDict = NULL; ensemblePtr->flags = flags; ensemblePtr->numParameters = 0; ensemblePtr->parameterList = NULL; ensemblePtr->unknownHandler = NULL; - ensemblePtr->token = Tcl_NRCreateCommand(interp, name, - NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, - ensemblePtr, DeleteEnsembleConfig); + ensemblePtr->token = token; ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; /* * Trigger an eventual recomputation of the ensemble command set. Note @@ -707,15 +698,56 @@ if (flags & ENSEMBLE_COMPILE) { ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; } - if (nameObj != NULL) { - TclDecrRefCount(nameObj); - } return ensemblePtr->token; + +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateEnsemble + * + * Create a simple ensemble attached to the given namespace. + * + * Deprecated by TclCreateEnsembleInNs. + * + * Value + * + * The token for the command created. + * + * Effect + * The ensemble is created and marked for compilation. + * + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateEnsemble( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *namespacePtr, + int flags) +{ + Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr, + *actualNsPtr; + const char * simpleName; + + if (nsPtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } + + TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN, + &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); + return TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); } + /* *---------------------------------------------------------------------- * * Tcl_SetEnsembleSubcommandList -- @@ -1883,10 +1915,11 @@ * Hand off to the target command. */ TclSkipTailcall(interp); Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } unknownOrAmbiguousSubcommand: /* @@ -2395,19 +2428,37 @@ * Side effects: * Memory is (eventually) deallocated. * *---------------------------------------------------------------------- */ + +static void +ClearTable( + EnsembleConfig *ensemblePtr) +{ + Tcl_HashTable *hash = &ensemblePtr->subcommandTable; + + if (hash->numEntries != 0) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); + + while (hPtr != NULL) { + Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(prefixObj); + hPtr = Tcl_NextHashEntry(&search); + } + ckfree((char *) ensemblePtr->subcommandArrayPtr); + } + Tcl_DeleteHashTable(hash); +} static void DeleteEnsembleConfig( ClientData clientData) { EnsembleConfig *ensemblePtr = clientData; Namespace *nsPtr = ensemblePtr->nsPtr; - Tcl_HashSearch search; - Tcl_HashEntry *hEnt; /* * Unlink from the ensemble chain if it has not been marked as having been * done already. */ @@ -2437,21 +2488,11 @@ /* * Kill the pointer-containing fields. */ - if (ensemblePtr->subcommandTable.numEntries != 0) { - ckfree(ensemblePtr->subcommandArrayPtr); - } - hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search); - while (hEnt != NULL) { - Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt); - - Tcl_DecrRefCount(prefixObj); - hEnt = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&ensemblePtr->subcommandTable); + ClearTable(ensemblePtr); if (ensemblePtr->subcmdList != NULL) { Tcl_DecrRefCount(ensemblePtr->subcmdList); } if (ensemblePtr->parameterList != NULL) { Tcl_DecrRefCount(ensemblePtr->parameterList); @@ -2503,104 +2544,105 @@ * the namespace that backs up this * ensemble. */ int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; - - if (hash->numEntries != 0) { - /* - * Remove pre-existing table. - */ - - ckfree(ensemblePtr->subcommandArrayPtr); - hPtr = Tcl_FirstHashEntry(hash, &search); - while (hPtr != NULL) { - Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); - - Tcl_DecrRefCount(prefixObj); - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(hash); - Tcl_InitHashTable(hash, TCL_STRING_KEYS); - } - - /* - * See if we've got an export list. If so, we will only export exactly - * those commands, which may be either implemented by the prefix in the - * subcommandDict or mapped directly onto the namespace's commands. - */ - - if (ensemblePtr->subcmdList != NULL) { - Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj; - int subcmdc; - - TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc, - &subcmdv); - for (i=0 ; isubcommandDict != NULL) { - Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], - &target); - if (target != NULL) { - Tcl_SetHashValue(hPtr, target); - Tcl_IncrRefCount(target); - continue; - } - } - - /* - * Not there, so map onto the namespace. Note in this case that we - * do not guarantee that the command is actually there; that is - * the programmer's responsibility (or [::unknown] of course). - */ - - cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr); - if (ensemblePtr->nsPtr->parentPtr != NULL) { - Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); - } else { - Tcl_AppendStringsToObj(cmdObj, name, NULL); - } - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - } else if (ensemblePtr->subcommandDict != NULL) { - /* - * No subcmd list, but we do have a mapping dictionary so we should - * use the keys of that. Convert the dictionary's contents into the - * form required for the ensemble's internal hashtable. - */ - - Tcl_DictSearch dictSearch; - Tcl_Obj *keyObj, *valueObj; - int done; - - Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, - &keyObj, &valueObj, &done); - while (!done) { - const char *name = TclGetString(keyObj); - - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - Tcl_SetHashValue(hPtr, valueObj); - Tcl_IncrRefCount(valueObj); - Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); - } + Tcl_Obj *mapDict = ensemblePtr->subcommandDict; + Tcl_Obj *subList = ensemblePtr->subcmdList; + + ClearTable(ensemblePtr); + Tcl_InitHashTable(hash, TCL_STRING_KEYS); + + if (subList) { + int subc; + Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; + char *name; + + /* + * There is a list of exactly what subcommands go in the table. + * Must determine the target for each. + */ + + Tcl_ListObjGetElements(NULL, subList, &subc, &subv); + if (subList == mapDict) { + /* + * Strange case where explicit list of subcommands is same value + * as the dict mapping to targets. + */ + + for (i = 0; i < subc; i += 2) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(cmdObj); + } + Tcl_SetHashValue(hPtr, subv[i+1]); + Tcl_IncrRefCount(subv[i+1]); + + name = TclGetString(subv[i+1]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (isNew) { + cmdObj = Tcl_NewStringObj(name, -1); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else { + /* Usual case where we can freely act on the list and dict. */ + + for (i = 0; i < subc; i++) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + continue; + } + + /* Lookup target in the dictionary */ + if (mapDict) { + Tcl_DictObjGet(NULL, mapDict, subv[i], &target); + if (target) { + Tcl_SetHashValue(hPtr, target); + Tcl_IncrRefCount(target); + continue; + } + } + + /* + * target was not in the dictionary so map onto the namespace. + * Note in this case that we do not guarantee that the + * command is actually there; that is the programmer's + * responsibility (or [::unknown] of course). + */ + cmdObj = Tcl_NewStringObj(name, -1); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else if (mapDict) { + /* + * No subcmd list, but we do have a mapping dictionary so we should + * use the keys of that. Convert the dictionary's contents into the + * form required for the ensemble's internal hashtable. + */ + + Tcl_DictSearch dictSearch; + Tcl_Obj *keyObj, *valueObj; + int done; + + Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, + &keyObj, &valueObj, &done); + while (!done) { + char *name = TclGetString(keyObj); + + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + Tcl_SetHashValue(hPtr, valueObj); + Tcl_IncrRefCount(valueObj); + Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); + } } else { /* * Discover what commands are actually exported by the namespace. * What we have is an array of patterns and a hash table whose keys * are the command names exported by the namespace (the contents do @@ -2632,15 +2674,11 @@ */ if (isNew) { Tcl_Obj *cmdObj, *cmdPrefixObj; - TclNewObj(cmdObj); - Tcl_AppendStringsToObj(cmdObj, - ensemblePtr->nsPtr->fullName, - (ensemblePtr->nsPtr->parentPtr ? "::" : ""), - nsCmdName, NULL); + cmdObj = Tcl_NewStringObj(nsCmdName, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } break; Index: generic/tclEvent.c ================================================================== --- generic/tclEvent.c +++ generic/tclEvent.c @@ -1055,11 +1055,10 @@ * converting to/from double. */ TclInitObjSubsystem(); /* Register obj types, create * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ - TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ subsystemsInitialized = 1; } TclpInitUnlock(); } Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -323,11 +323,11 @@ NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ case INST_JUMP_TRUE4: \ NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ default: \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F(0, (cleanup), 1); \ } \ @@ -344,11 +344,11 @@ NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ case INST_JUMP_TRUE4: \ NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ default: \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V(0, (cleanup), 1); \ } \ @@ -355,20 +355,20 @@ } while (0) #else /* TCL_COMPILE_DEBUG */ #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F((pcAdjustment), (cleanup), 1); \ } while (0) #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V((pcAdjustment), (cleanup), 1); \ } while (0) @@ -496,32 +496,12 @@ * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * ClientData *ptrPtr, int *tPtr); */ -#ifdef TCL_WIDE_INT_IS_LONG -#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclDoubleType) \ - ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ - ? (*(tPtr) = TCL_NUMBER_NAN) \ - : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ - ? TCL_ERROR : \ - TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#else /* !TCL_WIDE_INT_IS_LONG */ -#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclWideIntType) \ +#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ + (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_WIDE, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclDoubleType) \ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ @@ -530,11 +510,10 @@ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ ? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ /* * Macro used in this file to save a function call for common uses of * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: * @@ -541,12 +520,13 @@ * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * int *boolPtr); */ #define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ - ((((objPtr)->typePtr == &tclIntType) \ - || ((objPtr)->typePtr == &tclBooleanType)) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ + : ((objPtr)->typePtr == &tclBooleanType) \ ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) /* * Macro used to make the check for type overflow more mnemonic. This works by @@ -574,44 +554,10 @@ /* * Auxiliary tables used to compute powers of small integers. */ -#if (LONG_MAX == 0x7fffffff) - -/* - * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit - * signed integer. - */ - -static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14}; -static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long); - -/* - * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they - * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of - * powers of i+3; Exp32Value[i] gives the corresponding powers. - */ - -static const unsigned short Exp32Index[] = { - 0, 11, 18, 23, 26, 29, 31, 32, 33 -}; -static const size_t Exp32IndexSize = - sizeof(Exp32Index) / sizeof(unsigned short); -static const long Exp32Value[] = { - 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721, - 129140163, 387420489, 1162261467, 262144, 1048576, 4194304, - 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625, - 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056, - 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489, - 1000000000 -}; -static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long); -#endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */ - -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - /* * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a * Tcl_WideInt. */ @@ -711,11 +657,10 @@ (Tcl_WideInt)161051*161051*161051*11*11*11, (Tcl_WideInt)248832*248832*248832*12*12, (Tcl_WideInt)371293*371293*371293*13*13 }; static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); -#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */ /* * Markers for ExecuteExtendedBinaryMathOp. */ @@ -742,12 +687,10 @@ #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, int opcode, Tcl_Obj **constants, Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, Tcl_Obj *valuePtr); @@ -906,13 +849,13 @@ ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); ExecStack *esPtr = ckalloc(sizeof(ExecStack) + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; - TclNewLongObj(eePtr->constants[0], 0); + TclNewIntObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewLongObj(eePtr->constants[1], 1); + TclNewIntObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); eePtr->interp = interp; eePtr->callbackPtr = NULL; eePtr->corPtr = NULL; eePtr->rewind = 0; @@ -1875,41 +1818,10 @@ TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - long augend = *((const long *) ptr1); - long addend = *((const long *) ptr2); - long sum = augend + addend; - - /* - * Overflow when (augend and sum have different sign) and (augend and - * addend have the same sign). This is encapsulated in the Overflowing - * macro. - */ - - if (!Overflowing(augend, addend, sum)) { - TclSetLongObj(valuePtr, sum); - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - { - Tcl_WideInt w1 = (Tcl_WideInt) augend; - Tcl_WideInt w2 = (Tcl_WideInt) addend; - - /* - * We know the sum value is outside the long range, so we use the - * macro form that doesn't range test again. - */ - - TclSetWideIntObj(valuePtr, w1 + w2); - return TCL_OK; - } -#endif - } - if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* * Produce error message (reparse?!) */ @@ -1923,11 +1835,10 @@ TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, incrPtr, &w2); @@ -1936,15 +1847,14 @@ /* * Check for overflow. */ if (!Overflowing(w1, w2, sum)) { - Tcl_SetWideIntObj(valuePtr, sum); + TclSetIntObj(valuePtr, sum); return TCL_OK; } } -#endif Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); mp_add(&value, &incr, &value); mp_clear(&incr); @@ -3624,13 +3534,11 @@ /*TODO: Consider more untangling here; merge with LOAD and STORE ? */ { Tcl_Obj *incrPtr; -#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; -#endif long increment; case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: case INST_INCR_ARRAY_STK: @@ -3725,13 +3633,13 @@ ClientData ptr; int type; objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_LONG) { - long augend = *((const long *)ptr); - long sum = augend + increment; + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt augend = *((const Tcl_WideInt *)ptr); + Tcl_WideInt sum = augend + increment; /* * Overflow when (augend and sum have different sign) and * (augend and increment have the same sign). This is * encapsulated in the Overflowing macro. @@ -3739,20 +3647,19 @@ if (!Overflowing(augend, increment, sum)) { TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ - TclNewLongObj(objResultPtr, sum); + TclNewIntObj(objResultPtr, sum); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; - TclSetLongObj(objPtr, sum); + TclSetIntObj(objPtr, sum); } goto doneIncr; } -#ifndef TCL_WIDE_INT_IS_LONG w = (Tcl_WideInt)augend; TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ @@ -3765,58 +3672,24 @@ /* * We know the sum value is outside the long range; * use macro form that doesn't range test again. */ - TclSetWideIntObj(objPtr, w+increment); - } - goto doneIncr; -#endif - } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt sum; - - w = *((const Tcl_WideInt *) ptr); - sum = w + increment; - - /* - * Check for overflow. - */ - - if (!Overflowing(w, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We *do not* know the sum value is outside the - * long range (wide + long can yield long); use - * the function call that checks range. - */ - - Tcl_SetWideIntObj(objPtr, sum); - } - goto doneIncr; - } - } -#endif + TclSetIntObj(objPtr, w+increment); + } + goto doneIncr; + } /* end if (type == TCL_NUMBER_WIDE) */ } if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared */ objResultPtr = Tcl_DuplicateObj(objPtr); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; } - TclNewLongObj(incrPtr, increment); + TclNewIntObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); TRACE_ERROR(interp); goto gotError; } @@ -3826,11 +3699,11 @@ /* * All other cases, flow through to generic handling. */ - TclNewLongObj(incrPtr, increment); + TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); doIncrScalar: varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -4524,11 +4397,11 @@ } TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); } case INST_INFO_LEVEL_NUM: - TclNewLongObj(objResultPtr, iPtr->varFramePtr->level); + TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); case INST_INFO_LEVEL_ARGS: { int level; register CallFrame *framePtr = iPtr->varFramePtr; @@ -4893,11 +4766,11 @@ TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - TclNewLongObj(objResultPtr, length); + TclNewIntObj(objResultPtr, length); TRACE_APPEND(("%d\n", length)); NEXT_INST_F(1, 1, 1); case INST_LIST_INDEX: /* lindex with objc == 3 */ value2Ptr = OBJ_AT_TOS; @@ -5364,11 +5237,11 @@ JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); - TclNewLongObj(objResultPtr, length); + TclNewIntObj(objResultPtr, length); TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); case INST_STR_UPPER: valuePtr = OBJ_AT_TOS; @@ -5719,19 +5592,19 @@ case INST_STR_FIND: match = TclStringFind(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewLongObj(objResultPtr, match); + TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: match = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1); TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewLongObj(objResultPtr, match); + TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_CLASS: opnd = TclGetInt1AtPtr(pc+1); valuePtr = OBJ_AT_TOS; @@ -5900,42 +5773,34 @@ */ { ClientData ptr1, ptr2; int type1, type2; - long l1, l2, lResult; + Tcl_WideInt w1, w2, wResult; case INST_NUM_TYPE: if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { type1 = 0; - } else if (type1 == TCL_NUMBER_LONG) { - /* value is between LONG_MIN and LONG_MAX */ + } else if (type1 == TCL_NUMBER_WIDE) { + /* value is between WIDE_MIN and WIDE_MAX */ /* [string is integer] is -UINT_MAX to UINT_MAX range */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ int i; - if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { - type1 = TCL_NUMBER_WIDE; - } -#ifndef TCL_WIDE_INT_IS_LONG - } else if (type1 == TCL_NUMBER_WIDE) { - /* value is between WIDE_MIN and WIDE_MAX */ - /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ - int i; if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { type1 = TCL_NUMBER_LONG; } -#endif } else if (type1 == TCL_NUMBER_BIG) { /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ Tcl_WideInt w; if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { type1 = TCL_NUMBER_WIDE; } } - TclNewLongObj(objResultPtr, type1); + TclNewIntObj(objResultPtr, type1); TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); NEXT_INST_F(1, 1, 1); case INST_EQ: case INST_NEQ: @@ -5966,14 +5831,14 @@ } if (valuePtr == value2Ptr) { compare = MP_EQ; goto convertComparison; } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); - compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); + compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); } else { compare = TclCompareTwoNumbers(valuePtr, value2Ptr); } /* @@ -6045,57 +5910,57 @@ /* * Check for common, simple case. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_MOD: - if (l2 == 0) { + if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((l2 == 1) || (l2 == -1)) { + } else if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (l1 == 0) { + } else if (w1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { - lResult = l1 / l2; + wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if ((lResult < 0 || (lResult == 0 && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - (lResult * l2 != l1)) { - lResult -= 1; + if ((wResult < 0 || (wResult == 0 && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + (wResult * w2 != w1)) { + wResult -= 1; } - lResult = l1 - l2*lResult; - goto longResultOfArithmetic; + wResult = w1 - w2*wResult; + goto wideResultOfArithmetic; } case INST_RSHIFT: - if (l2 < 0) { + if (w2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", @@ -6102,48 +5967,48 @@ "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (l1 == 0) { + } else if (w1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { /* * Quickly force large right shifts to 0 or -1. */ - if (l2 >= (long)(CHAR_BIT*sizeof(long))) { + if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(long))) { /* * We assume that INT_MAX is much larger than the * number of bits in a long. This is a pretty safe * assumption, given that the former is usually around * 4e9 and the latter 32 or 64... */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (l1 > 0L) { + if (w1 > 0L) { objResultPtr = TCONST(0); } else { - TclNewLongObj(objResultPtr, -1); + TclNewIntObj(objResultPtr, -1); } TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } /* * Handle shifts within the native long range. */ - lResult = l1 >> ((int) l2); - goto longResultOfArithmetic; + wResult = w1 >> ((int) w2); + goto wideResultOfArithmetic; } case INST_LSHIFT: - if (l2 < 0) { + if (w2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", @@ -6150,16 +6015,16 @@ "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (l1 == 0) { + } else if (w1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (l2 > (long) INT_MAX) { + } else if (w2 > (Tcl_WideInt) INT_MAX) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) * in an mp_int, but since we're using mp_mul_2d() to do * the work, and it takes only an int argument, that's a * good place to draw the line. @@ -6173,21 +6038,21 @@ "integer value too large to represent", NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else { - int shift = (int) l2; + int shift = (int) w2; /* * Handle shifts within the native long range. */ - if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0) - && !((l1>0 ? l1 : ~l1) & + if ((size_t) shift < CHAR_BIT*sizeof(long) && (w1 != 0) + && !((w1>0 ? w1 : ~w1) & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - lResult = l1 << shift; - goto longResultOfArithmetic; + wResult = w1 << shift; + goto wideResultOfArithmetic; } } /* * Too large; need to use the broken-out function. @@ -6195,27 +6060,18 @@ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); break; case INST_BITAND: - lResult = l1 & l2; - goto longResultOfArithmetic; + wResult = w1 & w2; + goto wideResultOfArithmetic; case INST_BITOR: - lResult = l1 | l2; - goto longResultOfArithmetic; + wResult = w1 | w2; + goto wideResultOfArithmetic; case INST_BITXOR: - lResult = l1 ^ l2; - longResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, lResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - TclSetLongObj(valuePtr, lResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + wResult = w1 ^ w2; + goto wideResultOfArithmetic; } } /* * DO NOT MERGE THIS WITH THE EQUIVALENT SECTION LATER! That would @@ -6294,37 +6150,28 @@ /* * Handle (long,long) arithmetic as best we can without going out to * an external function. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - Tcl_WideInt w1, w2, wResult; - - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_ADD: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; wResult = w1 + w2; -#ifdef TCL_WIDE_INT_IS_LONG /* * Check for overflow. */ if (Overflowing(w1, w2, wResult)) { goto overflow; } -#endif goto wideResultOfArithmetic; case INST_SUB: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; wResult = w1 - w2; -#ifdef TCL_WIDE_INT_IS_LONG /* * Must check for overflow. The macro tests for overflows in * sums by looking at the sign bits. As we have a subtraction * here, we are adding -w2. As -w2 could in turn overflow, we * test with ~w2 instead: it has the opposite sign bit to w2 @@ -6334,57 +6181,56 @@ */ if (Overflowing(w1, ~w2, wResult)) { goto overflow; } -#endif wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewWideIntObj(wResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - Tcl_SetWideIntObj(valuePtr, wResult); + TclSetIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); case INST_DIV: - if (l2 == 0) { + if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((l1 == LONG_MIN) && (l2 == -1)) { + } else if ((w1 == LLONG_MIN) && (w2 == -1)) { /* - * Can't represent (-LONG_MIN) as a long. + * Can't represent (-LLONG_MIN) as a long. */ goto overflow; } - lResult = l1 / l2; + wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if (((lResult < 0) || ((lResult == 0) && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - ((lResult * l2) != l1)) { - lResult -= 1; + if (((wResult < 0) || ((wResult == 0) && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + ((wResult * w2) != w1)) { + wResult -= 1; } - goto longResultOfArithmetic; + goto wideResultOfArithmetic; case INST_MULT: if (((sizeof(long) >= 2*sizeof(int)) - && (l1 <= INT_MAX) && (l1 >= INT_MIN) - && (l2 <= INT_MAX) && (l2 >= INT_MIN)) + && (w1 <= INT_MAX) && (w1 >= INT_MIN) + && (w2 <= INT_MAX) && (w2 >= INT_MIN)) || ((sizeof(long) >= 2*sizeof(short)) - && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN) - && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) { - lResult = l1 * l2; - goto longResultOfArithmetic; + && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN) + && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) { + wResult = w1 * w2; + goto wideResultOfArithmetic; } } /* * Fall through with INST_EXPON, INST_DIV and large multiplies. @@ -6447,18 +6293,18 @@ DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); CACHE_STACK_INFO(); goto gotError; } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *) ptr1); + if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *) ptr1); if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, ~l1); + TclNewIntObj(objResultPtr, ~w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetLongObj(valuePtr, ~l1); + TclSetIntObj(valuePtr, ~w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { @@ -6484,19 +6330,19 @@ switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); - case TCL_NUMBER_LONG: - l1 = *((const long *) ptr1); - if (l1 != LONG_MIN) { + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *) ptr1); + if (w1 != LLONG_MIN) { if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, -l1); + TclNewIntObj(objResultPtr, -w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetLongObj(valuePtr, -l1); + TclSetIntObj(valuePtr, -w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ } @@ -6653,14 +6499,14 @@ iterTmpIndex = infoPtr->loopCtTemp; iterVarPtr = LOCAL(iterTmpIndex); oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { - TclNewLongObj(iterVarPtr->value.objPtr, -1); + TclNewIntObj(iterVarPtr->value.objPtr, -1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); } else { - TclSetLongObj(oldValuePtr, -1); + TclSetIntObj(oldValuePtr, -1); } TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); #ifndef TCL_COMPILE_DEBUG /* @@ -6690,12 +6536,12 @@ * Increment the temp holding the loop iteration number. */ iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; - iterNum = valuePtr->internalRep.longValue + 1; - TclSetLongObj(valuePtr, iterNum); + iterNum = valuePtr->internalRep.wideValue + 1; + TclSetIntObj(valuePtr, iterNum); /* * Check whether all value lists are exhausted and we should stop the * loop. */ @@ -7024,11 +6870,11 @@ Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: - TclNewLongObj(objResultPtr, result); + TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); case INST_PUSH_RETURN_OPTIONS: DECACHE_STACK_INFO(); @@ -7690,11 +7536,10 @@ wval = (Tcl_WideInt) now.sec; break; default: Tcl_Panic("clockRead instruction with unknown clock#"); } - /* TclNewWideObj(objResultPtr, wval); doesn't exist */ objResultPtr = Tcl_NewWideIntObj(wval); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(2, 0, 1); } @@ -8122,23 +7967,15 @@ int opcode, /* What operation to perform. */ Tcl_Obj **constants, /* The execution environment's constants. */ Tcl_Obj *valuePtr, /* The first operand on the stack. */ Tcl_Obj *value2Ptr) /* The second operand on the stack. */ { -#define LONG_RESULT(l) \ - if (Tcl_IsShared(valuePtr)) { \ - TclNewLongObj(objResultPtr, l); \ - return objResultPtr; \ - } else { \ - Tcl_SetLongObj(valuePtr, l); \ - return NULL; \ - } #define WIDE_RESULT(w) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewWideIntObj(w); \ } else { \ - Tcl_SetWideIntObj(valuePtr, w); \ + TclSetIntObj(valuePtr, w); \ return NULL; \ } #define BIG_RESULT(b) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewBignumObj(b); \ @@ -8156,11 +7993,10 @@ } int type1, type2; ClientData ptr1, ptr2; double d1, d2, dResult; - long l1, l2, lResult; Tcl_WideInt w1, w2, wResult; mp_int big1, big2, bigResult, bigRemainder; Tcl_Obj *objResultPtr; int invalid, numPos, zero; long shift; @@ -8170,25 +8006,24 @@ switch (opcode) { case INST_MOD: /* TODO: Attempts to re-use unshared operands on stack */ - l2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *)ptr2); - if (l2 == 0) { + w2 = 0; /* silence gcc warning */ + if (type2 == TCL_NUMBER_WIDE) { + w2 = *((const Tcl_WideInt *)ptr2); + if (w2 == 0) { return DIVIDED_BY_ZERO; } - if ((l2 == 1) || (l2 == -1)) { + if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ return constants[0]; } } -#ifndef TCL_WIDE_INT_IS_LONG if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *)ptr1); if (type2 != TCL_NUMBER_BIG) { Tcl_WideInt wQuotient, wRemainder; Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); @@ -8229,11 +8064,10 @@ */ mp_clear(&big2); return NULL; } -#endif Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); @@ -8256,18 +8090,13 @@ /* * Reject negative shift argument. */ switch (type2) { - case TCL_NUMBER_LONG: - invalid = (*((const long *)ptr2) < 0L); - break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); invalid = (mp_cmp_d(&big2, 0) == MP_LT); mp_clear(&big2); break; @@ -8283,11 +8112,11 @@ /* * Zero shifted any number of bits is still zero. */ - if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { + if ((type1==TCL_NUMBER_WIDE) && (*((const Tcl_WideInt *)ptr1) == (Tcl_WideInt)0)) { return constants[0]; } if (opcode == INST_LSHIFT) { /* @@ -8296,12 +8125,12 @@ * BEWARE! Can't use Tcl_GetIntFromObj() here because that * converts values in the (unsigned) range to their signed int * counterparts, leading to incorrect results. */ - if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > (long) INT_MAX)) { + if ((type2 != TCL_NUMBER_WIDE) + || (*((const Tcl_WideInt *)ptr2) > (long) INT_MAX)) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) in * an mp_int, but since we're using mp_mul_2d() to do the * work, and it takes only an int argument, that's a good * place to draw the line. @@ -8309,11 +8138,11 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } - shift = (int)(*((const long *)ptr2)); + shift = (int)(*((const Tcl_WideInt *)ptr2)); /* * Handle shifts within the native wide range. */ @@ -8329,29 +8158,24 @@ } else { /* * Quickly force large right shifts to 0 or -1. */ - if ((type2 != TCL_NUMBER_LONG) - || (*(const long *)ptr2 > INT_MAX)) { + if ((type2 != TCL_NUMBER_WIDE) + || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) { /* * Again, technically, the value to be shifted could be an * mp_int so huge that a right shift by (INT_MAX+1) bits could * not take us to the result of 0 or -1, but since we're using * mp_div_2d to do the work, and it takes only an int * argument, we draw the line there. */ switch (type1) { - case TCL_NUMBER_LONG: - zero = (*(const long *)ptr1 > 0L); - break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); zero = (mp_cmp_d(&big1, 0) == MP_GT); mp_clear(&big1); break; @@ -8360,15 +8184,14 @@ zero = 0; } if (zero) { return constants[0]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } - shift = (int)(*(const long *)ptr2); + shift = (int)(*(const Tcl_WideInt *)ptr2); -#ifndef TCL_WIDE_INT_IS_LONG /* * Handle shifts within the native wide range. */ if (type1 == TCL_NUMBER_WIDE) { @@ -8375,15 +8198,14 @@ w1 = *(const Tcl_WideInt *)ptr1; if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { if (w1 >= (Tcl_WideInt)0) { return constants[0]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } WIDE_RESULT(w1 >> shift); } -#endif } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); mp_init(&bigResult); @@ -8547,11 +8369,10 @@ mp_clear(&big1); mp_clear(&big2); BIG_RESULT(&bigResult); } -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); switch (opcode) { @@ -8568,29 +8389,28 @@ /* Unused, here to silence compiler warning. */ wResult = 0; } WIDE_RESULT(wResult); } -#endif - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (opcode) { case INST_BITAND: - lResult = l1 & l2; + wResult = w1 & w2; break; case INST_BITOR: - lResult = l1 | l2; + wResult = w1 | w2; break; case INST_BITXOR: - lResult = l1 ^ l2; + wResult = w1 ^ w2; break; default: /* Unused, here to silence compiler warning. */ - lResult = 0; + wResult = 0; } - LONG_RESULT(lResult); + WIDE_RESULT(wResult); case INST_EXPON: { int oddExponent = 0, negativeExponent = 0; unsigned short base; @@ -8602,64 +8422,58 @@ return EXPONENT_OF_ZERO; } dResult = pow(d1, d2); goto doubleResult; } - l1 = l2 = 0; - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *) ptr2); - if (l2 == 0) { + w2 = 0; + if (type2 == TCL_NUMBER_WIDE) { + w2 = *((const Tcl_WideInt *) ptr2); + if (w2 == 0) { /* * Anything to the zero power is 1. */ return constants[1]; - } else if (l2 == 1) { + } else if (w2 == 1) { /* * Anything to the first power is itself */ return NULL; } } switch (type2) { - case TCL_NUMBER_LONG: - negativeExponent = (l2 < 0); - oddExponent = (int) (l2 & 1); - break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); negativeExponent = (w2 < 0); oddExponent = (int) (w2 & (Tcl_WideInt)1); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); mp_mod_2d(&big2, 1, &big2); oddExponent = !mp_iszero(&big2); mp_clear(&big2); break; } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *)ptr1); + if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *)ptr1); } if (negativeExponent) { - if (type1 == TCL_NUMBER_LONG) { - switch (l1) { + if (type1 == TCL_NUMBER_WIDE) { + switch (w1) { case 0: /* * Zero to a negative power is div by zero error. */ return EXPONENT_OF_ZERO; case -1: if (oddExponent) { - LONG_RESULT(-1); + WIDE_RESULT(-1); } /* fallthrough */ case 1: /* * 1 to any power is 1. @@ -8675,12 +8489,12 @@ */ return constants[0]; } - if (type1 == TCL_NUMBER_LONG) { - switch (l1) { + if (type1 == TCL_NUMBER_WIDE) { + switch (w1) { case 0: /* * Zero to a positive power is zero. */ @@ -8693,154 +8507,71 @@ return constants[1]; case -1: if (!oddExponent) { return constants[1]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } } /* * We refuse to accept exponent arguments that exceed one mp_digit * which means the max exponent value is 2**28-1 = 0x0fffffff = * 268435455, which fits into a signed 32 bit int which is within the * range of the long int type. This means any numeric Tcl_Obj value - * not using TCL_NUMBER_LONG type must hold a value larger than we + * not using TCL_NUMBER_WIDE type must hold a value larger than we * accept. */ - if (type2 != TCL_NUMBER_LONG) { + if (type2 != TCL_NUMBER_WIDE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } - if (type1 == TCL_NUMBER_LONG) { - if (l1 == 2) { + if (type1 == TCL_NUMBER_WIDE) { + if (w1 == 2) { /* * Reduce small powers of 2 to shifts. */ - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(1L << l2); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(((Tcl_WideInt) 1) << l2); - } -#endif + if ((Tcl_WideUInt) w2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) { + WIDE_RESULT(((Tcl_WideInt) 1) << (int)w2); + } goto overflowExpon; } - if (l1 == -2) { + if (w1 == -2) { int signum = oddExponent ? -1 : 1; /* * Reduce small powers of 2 to shifts. */ - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(signum * (1L << l2)); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ - WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); - } -#endif + if ((Tcl_WideUInt)w2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); + } goto overflowExpon; } -#if (LONG_MAX == 0x7fffffff) - if (l2 - 2 < (long)MaxBase32Size - && l1 <= MaxBase32[l2 - 2] - && l1 >= -MaxBase32[l2 - 2]) { - /* - * Small powers of 32-bit integers. - */ - - lResult = l1 * l1; /* b**2 */ - switch (l2) { - case 2: - break; - case 3: - lResult *= l1; /* b**3 */ - break; - case 4: - lResult *= lResult; /* b**4 */ - break; - case 5: - lResult *= lResult; /* b**4 */ - lResult *= l1; /* b**5 */ - break; - case 6: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - break; - case 7: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - lResult *= l1; /* b**7 */ - break; - case 8: - lResult *= lResult; /* b**4 */ - lResult *= lResult; /* b**8 */ - break; - } - LONG_RESULT(lResult); - } - - if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - LONG_RESULT(Exp32Value[base]); - } - } - if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[-l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[-l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - lResult = (oddExponent) ? - -Exp32Value[base] : Exp32Value[base]; - LONG_RESULT(lResult); - } - } -#endif - } -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - if (type1 == TCL_NUMBER_LONG) { - w1 = l1; -#ifndef TCL_WIDE_INT_IS_LONG - } else if (type1 == TCL_NUMBER_WIDE) { - w1 = *((const Tcl_WideInt *) ptr1); -#endif + } + if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *) ptr1); } else { goto overflowExpon; } - if (l2 - 2 < (long)MaxBase64Size - && w1 <= MaxBase64[l2 - 2] - && w1 >= -MaxBase64[l2 - 2]) { + if (w2 - 2 < (long)MaxBase64Size + && w1 <= MaxBase64[w2 - 2] + && w1 >= -MaxBase64[w2 - 2]) { /* * Small powers of integers whose result is wide. */ wResult = w1 * w1; /* b**2 */ - switch (l2) { + switch (w2) { case 2: break; case 3: - wResult *= l1; /* b**3 */ + wResult *= w1; /* b**3 */ break; case 4: wResult *= wResult; /* b**4 */ break; case 5: @@ -8913,13 +8644,13 @@ * Handle cases of powers > 16 that still fit in a 64-bit word by * doing table lookup. */ if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); + + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[w1 - 2]) { /* * 64-bit number raised to intermediate power, done by * table lookup. */ @@ -8927,13 +8658,13 @@ WIDE_RESULT(Exp64Value[base]); } } if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[-w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); + + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[-w1 - 2]) { /* * 64-bit number raised to intermediate power, done by * table lookup. */ @@ -8940,11 +8671,10 @@ wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base]; WIDE_RESULT(wResult); } } -#endif overflowExpon: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if (big2.used > 1) { mp_clear(&big2); @@ -9020,13 +8750,11 @@ TclGetWideIntFromObj(NULL, value2Ptr, &w2); switch (opcode) { case INST_ADD: wResult = w1 + w2; -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif { /* * Check for overflow. */ @@ -9036,13 +8764,11 @@ } break; case INST_SUB: wResult = w1 - w2; -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif { /* * Must check for overflow. The macro tests for overflows * in sums by looking at the sign bits. As we have a * subtraction here, we are adding -w2. As -w2 could in @@ -9058,12 +8784,11 @@ } } break; case INST_MULT: - if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG) - || (sizeof(Tcl_WideInt) < 2*sizeof(long))) { + if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) { goto overflowBasic; } wResult = w1 * w2; break; @@ -9162,41 +8887,30 @@ (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); switch (opcode) { case INST_BITNOT: -#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); } -#endif Tcl_TakeBignumFromObj(NULL, valuePtr, &big); /* ~a = - a - 1 */ mp_neg(&big, &big); mp_sub_d(&big, 1, &big); BIG_RESULT(&big); case INST_UMINUS: switch (type) { case TCL_NUMBER_DOUBLE: DOUBLE_RESULT(-(*((const double *) ptr))); - case TCL_NUMBER_LONG: - w = (Tcl_WideInt) (*((const long *) ptr)); - if (w != LLONG_MIN) { - WIDE_RESULT(-w); - } - TclInitBignumFromLong(&big, *(const long *) ptr); - break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w = *((const Tcl_WideInt *) ptr); if (w != LLONG_MIN) { WIDE_RESULT(-w); } TclInitBignumFromWideInt(&big, w); break; -#endif default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } mp_neg(&big, &big); BIG_RESULT(&big); @@ -9203,11 +8917,10 @@ } Tcl_Panic("unexpected opcode"); return NULL; } -#undef LONG_RESULT #undef WIDE_RESULT #undef BIG_RESULT #undef DOUBLE_RESULT /* @@ -9235,43 +8948,34 @@ { int type1 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare; ClientData ptr1, ptr2; mp_int big1, big2; double d1, d2, tmp; - long l1, l2; -#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w1, w2; -#endif (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); switch (type1) { - case TCL_NUMBER_LONG: - l1 = *((const long *)ptr1); + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *)ptr1); switch (type2) { - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - longCompare: - return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); - w1 = (Tcl_WideInt)l1; - goto wideCompare; -#endif + wideCompare: + return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); - d1 = (double) l1; + d1 = (double) w1; /* * If the double has a fractional part, or if the long can be * converted to double without loss of precision, then compare as * doubles. */ - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1 + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { goto doubleCompare; } /* @@ -9290,48 +8994,10 @@ return MP_GT; } if (d2 > (double)LONG_MAX) { return MP_LT; } - l2 = (long) d2; - goto longCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - return compare; - } - -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: - w1 = *((const Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - wideCompare: - return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - w2 = (Tcl_WideInt)l2; - goto wideCompare; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) w1; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { - goto doubleCompare; - } - if (d2 < (double)LLONG_MIN) { - return MP_GT; - } - if (d2 > (double)LLONG_MAX) { - return MP_LT; - } w2 = (Tcl_WideInt) d2; goto wideCompare; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if (mp_cmp_d(&big2, 0) == MP_LT) { @@ -9340,35 +9006,18 @@ compare = MP_LT; } mp_clear(&big2); return compare; } -#endif case TCL_NUMBER_DOUBLE: d1 = *((const double *)ptr1); switch (type2) { case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); doubleCompare: return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - d2 = (double) l2; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2 - || modf(d1, &tmp) != 0.0) { - goto doubleCompare; - } - if (d1 < (double)LONG_MIN) { - return MP_LT; - } - if (d1 > (double)LONG_MAX) { - return MP_GT; - } - l1 = (long) d1; - goto longCompare; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { @@ -9380,11 +9029,10 @@ if (d1 > (double)LLONG_MAX) { return MP_GT; } w1 = (Tcl_WideInt) d1; goto wideCompare; -#endif case TCL_NUMBER_BIG: if (TclIsInfinite(d1)) { return (d1 > 0.0) ? MP_GT : MP_LT; } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); @@ -9408,14 +9056,11 @@ } case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: -#endif - case TCL_NUMBER_LONG: compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); @@ -9476,13 +9121,13 @@ * stdout. */ { Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_LL_MODIFIER "u, epoch %" TCL_LL_MODIFIER "u, interp 0x%p (epoch %" TCL_LL_MODIFIER "u)\n", - codePtr, (Tcl_WideInt)codePtr->refCount, (Tcl_WideInt)codePtr->compileEpoch, iPtr, - (Tcl_WideInt)iPtr->compileEpoch); + fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_LL_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n", + codePtr, (Tcl_WideInt)codePtr->refCount, codePtr->compileEpoch, iPtr, + iPtr->compileEpoch); fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", @@ -9624,11 +9269,20 @@ } else if (opcode <= INST_LNOT) { operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { - description = "non-numeric string"; + int numBytes; + const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); + + if (numBytes == 0) { + description = "empty string"; + } else if (TclCheckBadOctal(NULL, bytes)) { + description = "invalid octal number"; + } else { + description = "non-numeric string"; + } } else if (type == TCL_NUMBER_NAN) { description = "non-numeric floating-point value"; } else if (type == TCL_NUMBER_DOUBLE) { description = "floating-point value"; } else { @@ -9635,12 +9289,11 @@ /* TODO: No caller needs this. Eliminate? */ description = "(big) integer"; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s \"%s\" as operand of \"%s\"", description, - Tcl_GetString(opndPtr), operator)); + "can't use %s as operand of \"%s\"", description, operator)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } /* *---------------------------------------------------------------------- Index: generic/tclGet.c ================================================================== --- generic/tclGet.c +++ generic/tclGet.c @@ -140,11 +140,11 @@ code = TclSetBooleanFromAny(interp, &obj); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - *boolPtr = obj.internalRep.longValue; + *boolPtr = obj.internalRep.wideValue; } return code; } /* Index: generic/tclHistory.c ================================================================== --- generic/tclHistory.c +++ generic/tclHistory.c @@ -71,10 +71,17 @@ cmdPtr = Tcl_NewStringObj(cmd, -1); Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); + /* + * Move the interpreter's object result to the string result, then + * reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + /* * Discard the Tcl object created to hold the command. */ Tcl_DecrRefCount(cmdPtr); Index: generic/tclIO.c ================================================================== --- generic/tclIO.c +++ generic/tclIO.c @@ -9030,10 +9030,11 @@ * be marked busy. * *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) int TclCopyChannelOld( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Channel inChan, /* Channel to read from. */ Tcl_Channel outChan, /* Channel to write to. */ @@ -9041,10 +9042,11 @@ Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */ { return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, cmdPtr); } +#endif int TclCopyChannel( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Channel inChan, /* Channel to read from. */ Index: generic/tclIOCmd.c ================================================================== --- generic/tclIOCmd.c +++ generic/tclIOCmd.c @@ -135,11 +135,11 @@ newline = 0; if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { 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 * form of the command that is no longer recommended or * documented. See also [Bug #3151675]. Will be removed in Tcl 9, @@ -437,11 +437,11 @@ toRead = -1; 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 * documented. See also [Bug #3151675]. Will be removed in Tcl 9, * maybe even earlier. @@ -452,11 +452,11 @@ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected non-negative integer but got \"%s\"", 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 } } Index: generic/tclIORTrans.c ================================================================== --- generic/tclIORTrans.c +++ generic/tclIORTrans.c @@ -85,11 +85,11 @@ /* * Structure of the buffer to hold transform results to be consumed by higher * layers upon reading from the channel, plus the functions to manage such. */ -typedef struct _ResultBuffer_ { +typedef struct { unsigned char *buf; /* Reference to the buffer area. */ int allocated; /* Allocated size of the buffer area. */ int used; /* Number of bytes in the buffer, * <= allocated. */ } ResultBuffer; @@ -251,11 +251,11 @@ * forward an operation code, the argument details, and reference to results. * The command is assembled in the CT and belongs fully to that thread. No * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if * otherwise (static). */ } ForwardParamBase; @@ -296,11 +296,11 @@ /* * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ ReflectedTransform *rtPtr; /* Channel instance */ ForwardParam *param; /* Packaged arguments and return values, a Index: generic/tclIOUtil.c ================================================================== --- generic/tclIOUtil.c +++ generic/tclIOUtil.c @@ -243,11 +243,11 @@ * combination which was used, and the original and modified filenames, so * that we can correctly undo the entire operation when we want to unload the * code. */ -typedef struct FsDivertLoad { +typedef struct { Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; const Tcl_Filesystem *divertedFilesystem; ClientData divertedFileNativeRep; @@ -410,11 +410,10 @@ TclDStringAppendObj(cwdPtr, cwd); Tcl_DecrRefCount(cwd); return Tcl_DStringValue(cwdPtr); } -/* Obsolete */ int Tcl_EvalFile( Tcl_Interp *interp, /* Interpreter in which to process file. */ const char *fileName) /* Name of file to process. Tilde-substitution * will be performed on this name. */ @@ -829,19 +828,10 @@ { filesystemList = &nativeFilesystemRecord; 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 } /* *---------------------------------------------------------------------- * Index: generic/tclIndexObj.c ================================================================== --- generic/tclIndexObj.c +++ generic/tclIndexObj.c @@ -874,11 +874,12 @@ const char *message) /* Error message to print after the leading * objects in objv. The message may be * NULL. */ { Tcl_Obj *objPtr; - int i, len, elemLen, flags; + int i, len, elemLen; + char flags; Interp *iPtr = (Interp *) interp; const char *elementStr; /* * [incr Tcl] does something fairly horrific when generating error Index: generic/tclInt.decls ================================================================== --- generic/tclInt.decls +++ generic/tclInt.decls @@ -48,11 +48,11 @@ void TclCleanupCommand(Command *cmdPtr) } declare 7 { int TclCopyAndCollapse(int count, const char *src, char *dst) } -declare 8 { +declare 8 {deprecated {}} { int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) } # TclCreatePipeline unofficially exported for use by BLT. @@ -71,11 +71,11 @@ void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr) } declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } -# Removed in 8.5 +# Removed in 8.5: #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) #} declare 14 { @@ -86,11 +86,11 @@ # void TclExpandParseValue(ParseValue *pvPtr, int needed) # } declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } -# Removed in 8.4 +# Removed in 8.4: #declare 17 { # int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) #} #declare 18 { # int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv) @@ -112,20 +112,20 @@ declare 23 { Proc *TclFindProc(Interp *iPtr, const char *procName) } # Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10 declare 24 { - int TclFormatInt(char *buffer, long n) + int TclFormatInt(char *buffer, Tcl_WideInt n) } declare 25 { void TclFreePackageInfo(Interp *iPtr) } # Removed in 8.1: # declare 26 { # char *TclGetCwd(Tcl_Interp *interp) # } -# Removed in 8.5 +# Removed in 8.5: #declare 27 { # int TclGetDate(char *p, unsigned long now, long zone, # unsigned long *timePtr) #} declare 28 { @@ -145,11 +145,11 @@ } declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in Tcl 8.5 +# Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} declare 34 { int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -158,11 +158,11 @@ # Removed in 8.4b2: #declare 35 { # Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, # int flags) #} -# Removed in 8.6a2 +# Removed in 8.6a2: #declare 36 { # int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) #} declare 37 { int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) @@ -183,13 +183,13 @@ Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 43 { -# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 44 { int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr) } @@ -218,18 +218,18 @@ Namespace *nsPtr) } declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 52 { -# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int 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, int objc, Tcl_Obj *const objv[]) } @@ -271,11 +271,11 @@ } declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 65 { # int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, # Tcl_Obj *const objv[], int flags) #} #declare 66 { @@ -311,13 +311,11 @@ unsigned long TclpGetClicks(void) } declare 76 { unsigned long TclpGetSeconds(void) } - -# deprecated -declare 77 { +declare 77 {deprecated {}} { void TclpGetTime(Tcl_Time *time) } # Removed in 8.6: #declare 78 { # int TclpGetTimeZone(unsigned long time) @@ -355,11 +353,11 @@ # int flags, char **termPtr, ParseValue *pvPtr) # } # declare 87 { # void TclPlatformInit(Tcl_Interp *interp) # } -declare 88 { +declare 88 {deprecated {}} { char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags) } declare 89 { int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, @@ -378,11 +376,11 @@ const char *procName) } declare 93 { void TclProcDeleteProc(ClientData clientData) } -# Removed in Tcl 8.5: +# Removed in 8.5: #declare 94 { # int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, # int argc, const char **argv) #} # Replaced by Tcl_FSStat in 8.4: @@ -417,11 +415,11 @@ } declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -declare 104 { +declare 104 {deprecated {}} { int TclSockMinimumBuffersOld(int sock, int size) } # Replaced by Tcl_FSStat in 8.4: #declare 105 { # int TclStat(const char *path, Tcl_StatBuf *buf) @@ -453,30 +451,30 @@ void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 { - int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr) } declare 113 { - Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 { - void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) + void TclDeleteNamespace(Tcl_Namespace *nsPtr) } declare 115 { - int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst) } declare 116 { - Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, + Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 117 { - Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 118 { int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo) @@ -488,32 +486,32 @@ declare 120 { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 121 { - int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern) } declare 122 { - Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) + Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 123 { - void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, + void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr) } declare 124 { - Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp) } declare 125 { - Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp) } declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } declare 127 { - int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite) } declare 128 { void Tcl_PopCallFrame(Tcl_Interp *interp) } @@ -530,11 +528,11 @@ Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -declare 133 { +declare 133 {deprecated {}} { struct tm *TclpGetDate(const time_t *time, int useGMT) } # Removed in 8.5 #declare 134 { # size_t TclpStrftime(char *s, size_t maxsize, const char *format, @@ -548,11 +546,11 @@ #declare 137 { # 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, # char *sym2, Tcl_PackageInitProc **proc1Ptr, # Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) @@ -560,11 +558,11 @@ #declare 140 { # int TclLooksLikeInt(const char *bytes, int length) #} # 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, CompileHookProc *hookProc, ClientData clientData) } @@ -623,16 +621,14 @@ int status) } declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 158 { +declare 158 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptFileName(const char *filename) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 159 { +declare 159 {deprecated {use public Tcl_GetStartupScript()}} { const char *TclGetStartupScriptFileName(void) } #declare 160 { # int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, # Tcl_DString *dirPtr, char *pattern, char *tail, @@ -674,17 +670,14 @@ declare 166 { int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr) } -# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 167 { +declare 167 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptPath(Tcl_Obj *pathPtr) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 168 { +declare 168 {deprecated {use public Tcl_GetStartupScript()}} { Tcl_Obj *TclGetStartupScriptPath(void) } # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n) @@ -728,16 +721,15 @@ } declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h too declare 178 { - void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) + void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) } declare 179 { - Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) + Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr) } # REMOVED # Allocate lists without copying arrays # declare 180 { @@ -746,16 +738,14 @@ #declare 181 { # Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, # const char *file, int line) #} -# TclpGmtime and TclpLocaltime promoted to the generic interface from unix - -declare 182 { +declare 182 {deprecated {}} { struct tm *TclpLocaltime(const time_t *clock) } -declare 183 { +declare 183 {deprecated {}} { struct tm *TclpGmtime(const time_t *clock) } # For the new "Thread Storage" subsystem. @@ -935,14 +925,11 @@ int *newPtr) } declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } - - -# TIP 337 made this one public -declare 236 { +declare 236 {deprecated {use Tcl_BackgroundException}} { void TclBackgroundException(Tcl_Interp *interp, int code) } # TIP #285: Script cancellation support. declare 237 { @@ -1088,11 +1075,11 @@ } # new for 8.4.20+/8.5.12+ Cygwin only declare 10 win { Tcl_DirEntry *TclpReaddir(DIR *dir) } -# Removed in 8.3.1 (for Win32s only) +# Removed in 8.3.1 (for Win32s only): #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) #} # Pipe channel functions @@ -1138,11 +1125,10 @@ TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } -# new for 8.4.20+/8.5.12+ declare 21 win { char *TclpInetNtoa(struct in_addr addr) } # removed permanently for 8.4 #declare 21 win { Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -158,17 +158,17 @@ Tcl_ResolveRuntimeVarProc *fetchProc; Tcl_ResolveVarDeleteProc *deleteProc; } 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 { Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name @@ -263,20 +263,20 @@ Tcl_HashTable *childTablePtr; /* Contains any child namespaces. Indexed by * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif - size_t nsId; /* Unique id for the namespace. */ + unsigned long nsId; /* Unique id for the namespace. */ Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status * flags NS_DYING and NS_DEAD listed below. */ int activationCount; /* Number of "activations" or active call * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - int refCount; /* Count of references by namespaceName + unsigned int refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently * registered in the namespace. Indexed by * strings; values have type (Command *). @@ -297,16 +297,16 @@ * registered. */ int numExportPatterns; /* Number of export patterns currently * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - size_t cmdRefEpoch; /* Incremented if a newly added command + unsigned int cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - size_t resolverEpoch; /* Incremented whenever (a) the name + unsigned int resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This * invalidates all byte codes compiled in the * namespace, causing the code to be @@ -329,11 +329,11 @@ * usual variable resolution mechanism in Tcl. * This procedure is invoked within * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - size_t exportLookupEpoch; /* Incremented whenever a command is added to + unsigned int exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be * validated efficiently. */ Tcl_Ensemble *ensembles; /* List of structures that contain the details @@ -424,17 +424,17 @@ * defines whether the table contains valid data or will need to be recomputed * next time the ensemble command is called. */ 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 * existed; the global namespace never has an * ensemble command.) */ - size_t epoch; /* The epoch at which this ensemble's table of + unsigned int epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same * number of entries as there are entries in * the subcommandTable hash. */ @@ -543,11 +543,11 @@ * interested in: OR-ed combination of * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - int refCount; /* Used to ensure this structure is not + size_t refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ } CommandTrace; @@ -616,11 +616,11 @@ } value; } Var; typedef struct VarInHash { Var var; - int refCount; /* Counts number of active uses of this + unsigned int refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested * trace active on variable, and 1 if the * variable is a namespace variable. This @@ -948,11 +948,11 @@ */ typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - int refCount; /* Reference count: 1 if still present in + unsigned int refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount * becomes zero. */ struct Command *cmdPtr; /* Points to the Command structure for this @@ -1065,11 +1065,11 @@ * Will be grown to contain: pointers to the varnames (allocated at the end), * plus the init values for each variable (suitable to be memcopied on init) */ typedef struct LocalCache { - int refCount; + unsigned int refCount; int numVars; Tcl_Obj *varName0; } LocalCache; #define localName(framePtr, i) \ @@ -1227,11 +1227,11 @@ } CmdFrame; typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - int refCount; /* Number of times the word is on the + unsigned int refCount; /* Number of times the word is on the * stack. */ } CFWord; typedef struct CFWordBC { CmdFrame *framePtr; /* CmdFrame to access. */ @@ -1490,15 +1490,15 @@ struct LiteralEntry *nextPtr; /* Points to next entry in this hash bucket or * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - int refCount; /* If in an interpreter's global literal + size_t refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to - * 0. If in a local literal table, -1. */ + * 0. If in a local literal table, (size_t)-1. */ Namespace *nsPtr; /* Namespace in which this literal is used. We * try to avoid sharing literal non-FQ command * names among different namespaces to reduce * shimmering. */ } LiteralEntry; @@ -1514,11 +1514,11 @@ * **buckets. */ int numEntries; /* Total number of entries present in * table. */ int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - int mask; /* Mask value used in hashing function. */ + unsigned int mask; /* Mask value used in hashing function. */ } LiteralTable; /* * The following structure defines for each Tcl interpreter various * statistics-related information about the bytecode compiler and @@ -1632,16 +1632,16 @@ * already (this can happen if deleteProc * causes the command to be deleted or * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - int refCount; /* 1 if in command hashtable plus 1 for each + unsigned int refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - size_t cmdEpoch; /* Incremented to invalidate any references + unsigned int cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL * if no compile proc exists for command. */ Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */ @@ -1771,35 +1771,45 @@ *---------------------------------------------------------------- */ typedef struct Interp { /* - * The first two fields were named "result" and "freeProc" in earlier - * versions of Tcl. They are no longer used within Tcl, and are no - * longer available to be accessed by extensions. However, they cannot - * be removed. Why? There is a deployed base of stub-enabled extensions - * that query the value of iPtr->stubTable. For them to continue to work, - * the location of the field "stubTable" within the Interp struct cannot - * change. The most robust way to assure that is to leave all fields up to - * that one undisturbed. + * Note: the first three fields must match exactly the fields in a + * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the + * other. + * + * The interpreter's result is held in both the string and the + * objResultPtr fields. These fields hold, respectively, the result's + * string or object value. The interpreter's result is always in the + * result field if that is non-empty, otherwise it is in objResultPtr. + * The two fields are kept consistent unless some C code sets + * interp->result directly. Programs should not access result and + * objResultPtr directly; instead, they should always get and set the + * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and + * Tcl_GetStringResult. See the SetResult man page for details. */ - const char *legacyResult; - void (*legacyFreeProc) (void); + char *result; /* If the last command returned a string + * result, this points to it. Should not be + * accessed directly; see comment above. */ + Tcl_FreeProc *freeProc; /* Zero means a string result is statically + * allocated. TCL_DYNAMIC means string result + * was allocated with ckalloc and should be + * freed with ckfree. Other values give + * address of procedure to invoke to free the + * string result. Tcl_Eval must free it before + * executing next command. */ int errorLine; /* When TCL_ERROR is returned, this gives the * line number in the command where the error * occurred (1 means first line). */ const struct TclStubs *stubTable; - /* Pointer to the exported Tcl stub table. In - * ancient pre-8.1 versions of Tcl this was a - * pointer to the objResultPtr or a pointer to a - * buckets array in a hash table. Deployed stubs - * enabled extensions check for a NULL pointer value - * and for a TCL_STUBS_MAGIC value to verify they - * are not [load]ing into one of those pre-stubs - * interps. - */ + /* Pointer to the exported Tcl stub table. On + * previous versions of Tcl this is a pointer + * to the objResultPtr or a pointer to a + * buckets array in a hash table. We therefore + * have to do some careful checking before we + * can use this. */ TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ Namespace *globalNsPtr; /* The interpreter's global namespace. */ @@ -1814,11 +1824,11 @@ void (*optimizer)(void *envPtr); Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The * 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; /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. @@ -1845,10 +1855,29 @@ CallFrame *rootFramePtr; /* Global frame pointer for this * interpreter. */ Namespace *lookupNsPtr; /* Namespace to use ONLY on the next * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */ + /* + * Information used by Tcl_AppendResult to keep track of partial results. + * See Tcl_AppendResult code for details. + */ + +#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. */ + int appendAvl; /* Total amount of space available at + * partialResult. */ + int appendUsed; /* Number of non-null bytes currently stored + * at partialResult. */ +#else + char *appendResultDontUse; + int appendAvlDontUse; + int appendUsedDontUse; +#endif + /* * Information about packages. Used only in tclPkg.c. */ Tcl_HashTable packageTable; /* Describes all of the packages loaded in or @@ -1867,10 +1896,11 @@ * has been called for this interpreter. */ int evalFlags; /* Flags to control next call to Tcl_Eval. * Normally zero, but may be set before * calling Tcl_Eval. See below for valid * values. */ + int unused1; /* No longer used (was termOffset) */ LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl * objects holding literals of scripts * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ @@ -1904,10 +1934,18 @@ * evaluation stack. */ Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ +#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_DSTRING_STATIC_SIZE+1]; +# endif +#endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ Tcl_ThreadId threadId; /* ID of thread that owns the interpreter. */ @@ -2213,11 +2251,11 @@ * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the interp * has not be initialized. This is set 1 when we first * 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. * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be @@ -2346,19 +2384,19 @@ * used to hold all element pointers. This is done to make append operations * faster. */ typedef struct List { - int refCount; + unsigned int refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was * derived from the list representation. May * 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 \ (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) #define LIST_SIZE(numElems) \ @@ -2413,62 +2451,50 @@ * Tcl_GetIntFromObj and TclGetIntForIndex. * * WARNING: these macros eval their args more than once. */ -#define TclGetLongFromObj(interp, objPtr, longPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ - : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) - -#if (LONG_MAX == INT_MAX) -#define TclGetIntFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ - : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) -#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ - : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) -#else -#define TclGetIntFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \ - && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \ - ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ - : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) -#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ - (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.longValue >= INT_MIN \ - && (objPtr)->internalRep.longValue <= INT_MAX) \ - ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ - : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) -#endif +#if (LONG_MAX == LLONG_MAX) +#define TclGetLongFromObj(interp, objPtr, longPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ + : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) +#else +#define TclGetLongFromObj(interp, objPtr, longPtr) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.wideValue >= -(Tcl_WideInt)(ULONG_MAX) \ + && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(ULONG_MAX)) \ + ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \ + : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) +#endif + +#define TclGetIntFromObj(interp, objPtr, intPtr) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.wideValue >= -(Tcl_WideInt)(UINT_MAX) \ + && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(UINT_MAX)) \ + ? ((*(intPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ + : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) +#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.wideValue >= INT_MIN \ + && (objPtr)->internalRep.wideValue <= INT_MAX) \ + ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ + : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) /* * Macro used to save a function call for common uses of * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * Tcl_WideInt *wideIntPtr); */ -#ifdef TCL_WIDE_INT_IS_LONG #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#else /* !TCL_WIDE_INT_IS_LONG */ -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclWideIntType) \ - ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ - ((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ + ((objPtr)->internalRep.wideValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) /* * Flag values for TclTraceDictPath(). * * DICT_PATH_READ indicates that all entries on the path must exist but no @@ -2476,17 +2502,17 @@ * * DICT_PATH_UPDATE indicates that we are going to be doing an update at the * 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 #define DICT_PATH_UPDATE 1 #define DICT_PATH_EXISTS 2 @@ -2588,11 +2614,11 @@ *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr, +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); /* * A ProcessGlobalValue struct exists for each internal value in Tcl that is * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of @@ -2600,13 +2626,13 @@ * control. Each ProcessGlobalValue struct should be a static variable in some * file. */ typedef struct ProcessGlobalValue { - size_t epoch; /* Epoch counter to detect changes in the + unsigned int epoch; /* Epoch counter to detect changes in the * master value. */ - size_t numBytes; /* Length of the master string. */ + unsigned int numBytes; /* Length of the master string. */ char *value; /* The master string value. */ Tcl_Encoding encoding; /* system encoding when master string was * initialized. */ TclInitProcessGlobalValueProc *proc; /* A procedure to initialize the master string @@ -2690,13 +2716,10 @@ MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; -#ifndef TCL_WIDE_INT_IS_LONG -MODULE_SCOPE const Tcl_ObjType tclWideIntType; -#endif MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; /* * Variables denoting the hash key types defined in the core. @@ -2864,29 +2887,46 @@ int strLen, const unsigned char *pattern, int ptnLen, int flags); MODULE_SCOPE double TclCeil(const mp_int *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); +MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, + const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; +MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, int start, int *clNext); MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); +MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); +MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *nameNamespacePtr, + Tcl_Namespace *ensembleNamespacePtr, + int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); -/* TIP #280 - Modified token based evulation, with line information. */ +/* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; @@ -2905,10 +2945,12 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); +MODULE_SCOPE Tcl_Namespace * TclEnsureNamespace(Tcl_Interp *interp, + Tcl_Namespace *namespacePtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); MODULE_SCOPE void TclFinalizeEnvironment(void); @@ -2931,10 +2973,19 @@ MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); +MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); + MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE int * TclGetAsyncReadyPtr(void); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); @@ -3057,11 +3108,11 @@ MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - size_t *lengthPtr, Tcl_Encoding *encodingPtr); + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); MODULE_SCOPE void TclpMasterLock(void); @@ -3091,11 +3142,10 @@ MODULE_SCOPE void *TclInitPkgFiles(Tcl_Interp *interp); 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, void *data); MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status); @@ -3105,11 +3155,11 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); MODULE_SCOPE int TclScanElement(const char *string, int length, - int *flagPtr); + char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, mp_int *bignumValue); MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -3151,10 +3201,11 @@ int *clNextOuter, const char *outerScript); MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); +MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCount(int ch); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -3200,11 +3251,11 @@ MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp); 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[]); #endif MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, @@ -4378,11 +4429,11 @@ * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #define TclUtfToUniChar(str, chPtr) \ - ((((unsigned char) *(str)) < 0xC0) ? \ + ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) /* *---------------------------------------------------------------- @@ -4503,34 +4554,23 @@ * Macros used by the Tcl core to set a Tcl_Obj's numeric representation * avoiding the corresponding function calls in time critical parts of the * core. They should only be called on unshared objects. The ANSI C * "prototypes" for these macros are: * - * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); - * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ -#define TclSetLongObj(objPtr, i) \ +#define TclSetIntObj(objPtr, i) \ do { \ TclInvalidateStringRep(objPtr); \ TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ (objPtr)->typePtr = &tclIntType; \ } while (0) -#ifndef TCL_WIDE_INT_IS_LONG -#define TclSetWideIntObj(objPtr, w) \ - do { \ - TclInvalidateStringRep(objPtr); \ - TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ - (objPtr)->typePtr = &tclWideIntType; \ - } while (0) -#endif - #define TclSetDoubleObj(objPtr, d) \ do { \ TclInvalidateStringRep(objPtr); \ TclFreeIntRep(objPtr); \ (objPtr)->internalRep.doubleValue = (double)(d); \ @@ -4541,27 +4581,26 @@ *---------------------------------------------------------------- * Macros used by the Tcl core to create and initialise objects of standard * types, avoiding the corresponding function calls in time critical parts of * the core. The ANSI C "prototypes" for these macros are: * - * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l); - * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len); * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- */ #ifndef TCL_MEM_DEBUG -#define TclNewLongObj(objPtr, i) \ +#define TclNewIntObj(objPtr, i) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) #define TclNewDoubleObj(objPtr, d) \ @@ -4584,12 +4623,12 @@ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) #else /* TCL_MEM_DEBUG */ -#define TclNewLongObj(objPtr, l) \ - (objPtr) = Tcl_NewLongObj(l) +#define TclNewIntObj(objPtr, w) \ + (objPtr) = Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) #define TclNewStringObj(objPtr, s, len) \ Index: generic/tclIntDecls.h ================================================================== --- generic/tclIntDecls.h +++ generic/tclIntDecls.h @@ -26,25 +26,25 @@ # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif -/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ -#undef Tcl_CreateNamespace -#undef Tcl_DeleteNamespace -#undef Tcl_AppendExportList -#undef Tcl_Export -#undef Tcl_Import -#undef Tcl_ForgetImport -#undef Tcl_GetCurrentNamespace -#undef Tcl_GetGlobalNamespace -#undef Tcl_FindNamespace -#undef Tcl_FindCommand -#undef Tcl_GetCommandFromObj -#undef Tcl_GetCommandFullName -#undef Tcl_SetStartupScript -#undef Tcl_GetStartupScript +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) +/* Those macro's are especially for Itcl 3.4 compatibility */ +# define tclCreateNamespace tcl_CreateNamespace +# define tclDeleteNamespace tcl_DeleteNamespace +# define tclAppendExportList tcl_AppendExportList +# define tclExport tcl_Export +# define tclImport tcl_Import +# define tclForgetImport tcl_ForgetImport +# define tclGetCurrentNamespace_ tcl_GetCurrentNamespace +# define tclGetGlobalNamespace_ tcl_GetGlobalNamespace +# define tclFindNamespace tcl_FindNamespace +# define tclFindCommand tcl_FindCommand +# define tclGetCommandFromObj tcl_GetCommandFromObj +# define tclGetCommandFullName tcl_GetCommandFullName +#endif /* !defined(TCL_NO_DEPRECATED) */ /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the generic/tclInt.decls script. @@ -73,11 +73,12 @@ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ EXTERN int TclCopyAndCollapse(int count, const char *src, char *dst); /* 8 */ -EXTERN int TclCopyChannelOld(Tcl_Interp *interp, +TCL_DEPRECATED("") +int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 9 */ EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, @@ -111,11 +112,11 @@ const char **nextPtr, int *sizePtr, int *bracePtr); /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ -EXTERN int TclFormatInt(char *buffer, long n); +EXTERN int TclFormatInt(char *buffer, Tcl_WideInt n); /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* 28 */ @@ -171,11 +172,11 @@ EXTERN int TclInterpInit(Tcl_Interp *interp); /* Slot 52 is reserved */ /* 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, Tcl_Obj *const objv[]); /* 55 */ @@ -216,11 +217,12 @@ /* 75 */ EXTERN unsigned long TclpGetClicks(void); /* 76 */ EXTERN unsigned long TclpGetSeconds(void); /* 77 */ -EXTERN void TclpGetTime(Tcl_Time *time); +TCL_DEPRECATED("") +void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ EXTERN char * TclpRealloc(char *ptr, unsigned int size); @@ -229,11 +231,12 @@ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ /* 88 */ -EXTERN char * TclPrecTraceProc(ClientData clientData, +TCL_DEPRECATED("") +char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 89 */ EXTERN int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); @@ -265,11 +268,12 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffersOld(int sock, int size); +TCL_DEPRECATED("") +int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ /* 108 */ EXTERN void TclTeardownNamespace(Namespace *nsPtr); @@ -282,26 +286,26 @@ const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 112 */ -EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, +EXTERN int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 113 */ -EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 114 */ -EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); +EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr); /* 115 */ -EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 116 */ -EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, +EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ -EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 118 */ EXTERN int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); @@ -312,27 +316,27 @@ /* 120 */ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 121 */ -EXTERN int Tcl_ForgetImport(Tcl_Interp *interp, +EXTERN int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 122 */ -EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, +EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 123 */ -EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, +EXTERN void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 124 */ -EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp); /* 125 */ -EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp); /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 127 */ -EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 128 */ EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); /* 129 */ EXTERN int Tcl_PushCallFrame(Tcl_Interp *interp, @@ -348,23 +352,22 @@ Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 132 */ EXTERN int TclpHasSockets(Tcl_Interp *interp); /* 133 */ -EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT); +TCL_DEPRECATED("") +struct tm * TclpGetDate(const time_t *time, int useGMT); /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ /* 138 */ -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, ClientData clientData); /* 143 */ @@ -399,13 +402,15 @@ int status); /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); /* 158 */ -EXTERN void TclSetStartupScriptFileName(const char *filename); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptFileName(const char *filename); /* 159 */ -EXTERN const char * TclGetStartupScriptFileName(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 162 */ @@ -420,13 +425,15 @@ /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 167 */ -EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptPath(Tcl_Obj *pathPtr); /* 168 */ -EXTERN Tcl_Obj * TclGetStartupScriptPath(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n); /* 170 */ EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, @@ -455,20 +462,22 @@ /* 177 */ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 178 */ -EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr, +EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName); /* 179 */ -EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); +EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* 182 */ -EXTERN struct tm * TclpLocaltime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpLocaltime(const time_t *clock); /* 183 */ -EXTERN struct tm * TclpGmtime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpGmtime(const time_t *clock); /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ @@ -568,11 +577,12 @@ const char *key, int *newPtr); /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* 236 */ -EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); +TCL_DEPRECATED("use Tcl_BackgroundException") +void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ EXTERN int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, @@ -650,11 +660,11 @@ void (*tclAllocateFreeObjects) (void); /* 3 */ void (*reserved4)(void); int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */ - int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ + TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ void (*reserved13)(void); @@ -666,11 +676,11 @@ void (*reserved19)(void); void (*reserved20)(void); void (*reserved21)(void); int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ - int (*tclFormatInt) (char *buffer, long n); /* 24 */ + int (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ void (*reserved26)(void); void (*reserved27)(void); Tcl_Channel (*tclpGetDefaultStdChannel) (int type); /* 28 */ void (*reserved29)(void); @@ -695,11 +705,11 @@ void (*reserved48)(void); void (*reserved49)(void); 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); void (*reserved57)(void); Var * (*tclLookupVar) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 58 */ @@ -719,11 +729,11 @@ void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (char *ptr); /* 74 */ unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ - void (*tclpGetTime) (Tcl_Time *time); /* 77 */ + TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */ void (*reserved82)(void); @@ -730,11 +740,11 @@ void (*reserved83)(void); void (*reserved84)(void); void (*reserved85)(void); void (*reserved86)(void); void (*reserved87)(void); - char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ + TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */ void (*reserved90)(void); void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */ int (*tclProcCompileProc) (Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName); /* 92 */ void (*tclProcDeleteProc) (ClientData clientData); /* 93 */ @@ -746,48 +756,48 @@ void (*reserved99)(void); void (*reserved100)(void); CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ + TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ - int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ - Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ - void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ - int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ - Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ - Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ + int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ + Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ + void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ + int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ + Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ + Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */ int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */ Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */ - int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ - Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ - void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ - Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */ - Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */ + int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ + Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ + void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ + Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */ + Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */ void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ + int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ - struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); void (*reserved136)(void); void (*reserved137)(void); - CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ + 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 */ const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */ TclHandle (*tclHandleCreate) (void *ptr); /* 146 */ @@ -800,36 +810,36 @@ Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */ void (*reserved154)(void); void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ - const char * (*tclGetStartupScriptFileName) (void); /* 159 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ const void * (*tclGetInstructionTable) (void); /* 163 */ void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ - void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ - Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */ void (*reserved174)(void); int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */ - void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ - Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */ + void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ + Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); - struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ - struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ + TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ void (*reserved184)(void); void (*reserved185)(void); void (*reserved186)(void); void (*reserved187)(void); void (*reserved188)(void); @@ -878,11 +888,11 @@ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ + TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ @@ -1086,42 +1096,42 @@ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ #define TclSockMinimumBuffers \ (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -#define Tcl_AppendExportList \ - (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ -#define Tcl_CreateNamespace \ - (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ -#define Tcl_DeleteNamespace \ - (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ -#define Tcl_Export \ - (tclIntStubsPtr->tcl_Export) /* 115 */ -#define Tcl_FindCommand \ - (tclIntStubsPtr->tcl_FindCommand) /* 116 */ -#define Tcl_FindNamespace \ - (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ +#define TclAppendExportList \ + (tclIntStubsPtr->tclAppendExportList) /* 112 */ +#define TclCreateNamespace \ + (tclIntStubsPtr->tclCreateNamespace) /* 113 */ +#define TclDeleteNamespace \ + (tclIntStubsPtr->tclDeleteNamespace) /* 114 */ +#define TclExport \ + (tclIntStubsPtr->tclExport) /* 115 */ +#define TclFindCommand \ + (tclIntStubsPtr->tclFindCommand) /* 116 */ +#define TclFindNamespace \ + (tclIntStubsPtr->tclFindNamespace) /* 117 */ #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ -#define Tcl_ForgetImport \ - (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ -#define Tcl_GetCommandFromObj \ - (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ -#define Tcl_GetCommandFullName \ - (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ -#define Tcl_GetCurrentNamespace \ - (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ -#define Tcl_GetGlobalNamespace \ - (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ +#define TclForgetImport \ + (tclIntStubsPtr->tclForgetImport) /* 121 */ +#define TclGetCommandFromObj \ + (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */ +#define TclGetCommandFullName \ + (tclIntStubsPtr->tclGetCommandFullName) /* 123 */ +#define TclGetCurrentNamespace_ \ + (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */ +#define TclGetGlobalNamespace_ \ + (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */ #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ -#define Tcl_Import \ - (tclIntStubsPtr->tcl_Import) /* 127 */ +#define TclImport \ + (tclIntStubsPtr->tclImport) /* 127 */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ (tclIntStubsPtr->tcl_PushCallFrame) /* 129 */ #define Tcl_RemoveInterpResolvers \ @@ -1208,14 +1218,14 @@ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ #define TclCleanupVar \ (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -#define Tcl_SetStartupScript \ - (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ -#define Tcl_GetStartupScript \ - (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ +#define TclSetStartupScript \ + (tclIntStubsPtr->tclSetStartupScript) /* 178 */ +#define TclGetStartupScript \ + (tclIntStubsPtr->tclGetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ #define TclpLocaltime \ (tclIntStubsPtr->tclpLocaltime) /* 182 */ #define TclpGmtime \ @@ -1348,60 +1358,30 @@ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#undef TclGetStartupScriptFileName -#undef TclSetStartupScriptFileName -#undef TclGetStartupScriptPath -#undef TclSetStartupScriptPath -#undef TclBackgroundException - -#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) -# undef Tcl_SetStartupScript -# define Tcl_SetStartupScript \ - (tclStubsPtr->tcl_SetStartupScript) /* 622 */ -# undef Tcl_GetStartupScript -# define Tcl_GetStartupScript \ - (tclStubsPtr->tcl_GetStartupScript) /* 623 */ -# undef Tcl_CreateNamespace -# define Tcl_CreateNamespace \ - (tclStubsPtr->tcl_CreateNamespace) /* 506 */ -# undef Tcl_DeleteNamespace -# define Tcl_DeleteNamespace \ - (tclStubsPtr->tcl_DeleteNamespace) /* 507 */ -# undef Tcl_AppendExportList -# define Tcl_AppendExportList \ - (tclStubsPtr->tcl_AppendExportList) /* 508 */ -# undef Tcl_Export -# define Tcl_Export \ - (tclStubsPtr->tcl_Export) /* 509 */ -# undef Tcl_Import -# define Tcl_Import \ - (tclStubsPtr->tcl_Import) /* 510 */ -# undef Tcl_ForgetImport -# define Tcl_ForgetImport \ - (tclStubsPtr->tcl_ForgetImport) /* 511 */ -# undef Tcl_GetCurrentNamespace -# define Tcl_GetCurrentNamespace \ - (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */ -# undef Tcl_GetGlobalNamespace -# define Tcl_GetGlobalNamespace \ - (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */ -# undef Tcl_FindNamespace -# define Tcl_FindNamespace \ - (tclStubsPtr->tcl_FindNamespace) /* 514 */ -# undef Tcl_FindCommand -# define Tcl_FindCommand \ - (tclStubsPtr->tcl_FindCommand) /* 515 */ -# undef Tcl_GetCommandFromObj -# define Tcl_GetCommandFromObj \ - (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ -# undef Tcl_GetCommandFullName -# define Tcl_GetCommandFullName \ - (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ +#if defined(USE_TCL_STUBS) +# undef TclGetStartupScriptFileName +# undef TclSetStartupScriptFileName +# undef TclGetStartupScriptPath +# undef TclSetStartupScriptPath +# undef TclBackgroundException +# undef TclSetStartupScript +# undef TclGetStartupScript +# undef TclCreateNamespace +# undef TclDeleteNamespace +# undef TclAppendExportList +# undef TclExport +# undef TclImport +# undef TclForgetImport +# undef TclGetCurrentNamespace_ +# undef TclGetGlobalNamespace_ +# undef TclFindNamespace +# undef TclFindCommand +# undef TclGetCommandFromObj +# undef TclGetCommandFullName +# undef TclCopyChannelOld +# undef TclSockMinimumBuffersOld #endif -#undef TclCopyChannelOld -#undef TclSockMinimumBuffersOld - #endif /* _TCLINTDECLS */ Index: generic/tclIntPlatDecls.h ================================================================== --- generic/tclIntPlatDecls.h +++ generic/tclIntPlatDecls.h @@ -553,14 +553,22 @@ #if defined(_WIN32) # undef TclWinNToHS # undef TclWinGetServByName # undef TclWinGetSockOpt # undef TclWinSetSockOpt -# define TclWinNToHS ntohs -# define TclWinGetServByName getservbyname -# define TclWinGetSockOpt getsockopt -# define TclWinSetSockOpt setsockopt +# undef TclWinGetPlatformId +# 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)) #endif Index: generic/tclInterp.c ================================================================== --- generic/tclInterp.c +++ generic/tclInterp.c @@ -3206,14 +3206,10 @@ * Assume these functions all work. [Bug 2895741] */ (void) Tcl_EvalEx(interp, "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master, - "::tcl::mathfunc::min", 0, NULL); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master, - "::tcl::mathfunc::max", 0, NULL); } iPtr->flags |= SAFE_INTERP; /* Index: generic/tclLink.c ================================================================== --- generic/tclLink.c +++ generic/tclLink.c @@ -652,11 +652,11 @@ static Tcl_ObjType invalidRealType = { "invalidReal", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetInvalidRealFromAny /* setFromAnyProc */ + NULL /* setFromAnyProc */ }; static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { const char *str; Index: generic/tclListObj.c ================================================================== --- generic/tclListObj.c +++ generic/tclListObj.c @@ -53,26 +53,24 @@ /* *---------------------------------------------------------------------- * * NewListIntRep -- * - * Creates a 'List' structure with space for 'objc' elements. 'objc' must - * be > 0. If 'objv' is not NULL, The list is initialized with first - * 'objc' values in that array. Otherwise the list is initialized to have - * 0 elements, with space to add 'objc' more. Flag value 'p' indicates + * Creates a list internal rep with space for objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize list internal rep to have + * 0 elements, with space to add objc more. Flag value "p" indicates * how to behave on failure. * - * Value - * - * A new 'List' structure with refCount 0. If some failure - * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic' - * is called if it is not. - * - * Effect - * - * The refCount of each value in 'objv' is incremented as it is added - * to the list. + * Results: + * A new List struct with refCount 0 is returned. If some failure + * prevents this then if p=0, NULL is returned and otherwise the + * routine panics. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. * *---------------------------------------------------------------------- */ static List * @@ -132,14 +130,26 @@ } /* *---------------------------------------------------------------------- * - * AttemptNewList -- + * AttemptNewList -- * - * Like NewListIntRep, but additionally sets an error message on failure. - * + * Creates a list internal rep with space for objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize list internal rep to have + * 0 elements, with space to add objc more. + * + * Results: + * A new List struct with refCount 0 is returned. If some failure + * prevents this then NULL is returned, and an error message is left + * in the interp result, unless interp is NULL. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * *---------------------------------------------------------------------- */ static List * AttemptNewList( @@ -167,24 +177,27 @@ /* *---------------------------------------------------------------------- * * Tcl_NewListObj -- * - * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is - * defined, 'Tcl_DbNewListObj' is called instead. - * - * Value - * - * A new list 'Tcl_Obj' to which is appended values from 'objv', or if - * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no - * elements. The string representation of the new 'Tcl_Obj' is set to - * NULL. The refCount of the list is 0. - * - * Effect - * - * The refCount of each elements in 'objv' is incremented as it is added - * to the list. + * This function is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new list object from an + * (objc,objv) array: that is, each of the objc elements of the array + * referenced by objv is inserted as an element into a new Tcl object. + * + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewListObj. + * + * Results: + * A new list object is returned that is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation is left + * NULL. The resulting new list object has ref count 0. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG @@ -231,18 +244,32 @@ #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * - * Tcl_DbNewListObj -- - * - * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the - * file name and line number from its caller. This simplifies debugging - * since the [memory active] command will report the correct file - * name and line number when reporting objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead. + * Tcl_DbNewListObj -- + * + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same + * as the Tcl_NewListObj function above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the [memory active] + * command will report the correct file name and line number when + * reporting objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this function just returns the + * result of calling Tcl_NewListObj. + * + * Results: + * A new list object is returned that is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation is left + * NULL. The new list object has ref count 0. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG @@ -299,12 +326,23 @@ /* *---------------------------------------------------------------------- * * Tcl_SetListObj -- * - * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of - * creating a new one. + * Modify an object to be a list containing each of the objc elements of + * the object array referenced by objv. + * + * Results: + * None. + * + * Side effects: + * The object is made a list object and is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation is left + * NULL. The ref counts of the elements in objv are incremented since the + * list now refers to them. The object's old string and internal + * representations are freed and its type is set NULL. * *---------------------------------------------------------------------- */ void @@ -344,24 +382,22 @@ /* *---------------------------------------------------------------------- * * TclListObjCopy -- * - * Creates a new 'Tcl_Obj' which is a pure copy of a list value. This - * provides for the C level a counterpart of the [lrange $list 0 end] - * command, while using internals details to be as efficient as possible. - * - * Value - * - * The address of the new 'Tcl_Obj' which shares its internal - * representation with 'listPtr', and whose refCount is 0. If 'listPtr' - * is not actually a list, the value is NULL, and an error message is left - * in 'interp' if it is not NULL. - * - * Effect - * - * 'listPtr' is converted to a list if it isn't one already. + * Makes a "pure list" copy of a list value. This provides for the C + * level a counterpart of the [lrange $list 0 end] command, while using + * internals details to be as efficient as possible. + * + * Results: + * Normally returns a pointer to a new Tcl_Obj, that contains the same + * list value as *listPtr does. The returned Tcl_Obj has a refCount of + * zero. If *listPtr does not hold a list, NULL is returned, and if + * interp is non-NULL, an error message is recorded there. + * + * Side effects: + * None. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -387,34 +423,31 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjGetElements -- * - * Retreive the elements in a list 'Tcl_Obj'. - * - * Value - * - * TCL_OK - * - * A count of list elements is stored, 'objcPtr', And a pointer to the - * array of elements in the list is stored in 'objvPtr'. - * - * The elements accessible via 'objvPtr' should be treated as readonly - * and the refCount for each object is _not_ incremented; the caller - * must do that if it holds on to a reference. Furthermore, the - * pointer and length returned by this function may change as soon as - * any function is called on the list object. Be careful about - * retaining the pointer in a local data structure. - * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An error message is left in the - * interpreter's result if 'interp' is not NULL. - * - * Effect - * - * 'listPtr' is converted to a list object if it isn't one already. + * This function returns an (objc,objv) array of the elements in a list + * object. + * + * Results: + * The return value is normally TCL_OK; in this case *objcPtr is set to + * the count of list elements and *objvPtr is set to a pointer to an + * array of (*objcPtr) pointers to each list element. If listPtr does not + * refer to a list object and the object can not be converted to one, + * TCL_ERROR is returned and an error message will be left in the + * interpreter's result if interp is not NULL. + * + * The objects referenced by the returned array should be treated as + * readonly and their ref counts are _not_ incremented; the caller must + * do that if it holds on to a reference. Furthermore, the pointer and + * length returned by this function may change as soon as any function is + * called on the list object; be careful about retaining the pointer in a + * local data structure. + * + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. * *---------------------------------------------------------------------- */ int @@ -451,31 +484,24 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendList -- * - * Appends the elements of elemListPtr to those of listPtr. - * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR - * - * 'listPtr' or 'elemListPtr' are not valid lists. An error - * message is left in the interpreter's result if 'interp' is not NULL. - * - * Effect - * - * The reference count of each element of 'elemListPtr' as it is added to - * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType' - * if they are not already. Appending the new elements may cause the - * array of element pointers in 'listObj' to grow. If any objects are - * appended to 'listPtr'. Any preexisting string representation of - * 'listPtr' is invalidated. + * This function appends the elements in the list value referenced by + * elemListPtr to the list value referenced by listPtr. + * + * Results: + * The return value is normally TCL_OK. If listPtr or elemListPtr do not + * refer to list values, TCL_ERROR is returned and an error message is + * left in the interpreter's result if interp is not NULL. + * + * Side effects: + * The reference counts of the elements in elemListPtr are incremented + * since the list now refers to them. listPtr and elemListPtr are + * converted, if necessary, to list objects. Also, appending the new + * elements may cause listObj's array of element pointers to grow. + * listPtr's old string representation, if any, is invalidated. * *---------------------------------------------------------------------- */ int @@ -510,31 +536,28 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * - * Like 'Tcl_ListObjAppendList', but Appends a single value to a list. - * - * Value - * - * TCL_OK - * - * 'objPtr' is appended to the elements of 'listPtr'. - * - * TCL_ERROR - * - * listPtr does not refer to a list object and the object can not be - * converted to one. An error message will be left in the - * interpreter's result if interp is not NULL. - * - * Effect - * - * If 'listPtr' is not already of type 'tclListType', it is converted. - * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'. - * Appending the new element may cause the the array of element pointers - * in 'listObj' to grow. Any preexisting string representation of - * 'listPtr' is invalidated. + * This function is a special purpose version of Tcl_ListObjAppendList: + * it appends a single object referenced by objPtr to the list object + * referenced by listPtr. If listPtr is not already a list object, an + * attempt will be made to convert it to one. + * + * Results: + * The return value is normally TCL_OK; in this case objPtr is added to + * the end of listPtr's list. If listPtr does not refer to a list object + * and the object can not be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter's result if interp is + * not NULL. + * + * Side effects: + * The ref count of objPtr is incremented since the list now refers to + * it. listPtr will be converted, if necessary, to a list object. Also, + * appending the new element may cause listObj's array of element + * pointers to grow. listPtr's old string representation, if any, is + * invalidated. * *---------------------------------------------------------------------- */ int @@ -681,31 +704,27 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * - * Retrieve a pointer to the element of 'listPtr' at 'index'. The index - * of the first element is 0. - * - * Value - * - * TCL_OK - * - * A pointer to the element at 'index' is stored in 'objPtrPtr'. If - * 'index' is out of range, NULL is stored in 'objPtrPtr'. This - * object should be treated as readonly and its 'refCount' is _not_ - * incremented. The caller must do that if it holds on to the - * reference. - * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An an error message is left in the - * interpreter's result if 'interp' is not NULL. - * - * Effect - * - * If 'listPtr' is not already of type 'tclListType', it is converted. + * This function returns a pointer to the index'th object from the list + * referenced by listPtr. The first element has index 0. If index is + * negative or greater than or equal to the number of elements in the + * list, a NULL is returned. If listPtr is not a list object, an attempt + * will be made to convert it to a list. + * + * Results: + * The return value is normally TCL_OK; in this case objPtrPtr is set to + * the Tcl_Obj pointer for the index'th list element or NULL if index is + * out of range. This object should be treated as readonly and its ref + * count is _not_ incremented; the caller must do that if it holds on to + * the reference. If listPtr does not refer to a list and can't be + * converted to one, TCL_ERROR is returned and an error message is left + * in the interpreter's result if interp is not NULL. + * + * Side effects: + * listPtr will be converted, if necessary, to a list object. * *---------------------------------------------------------------------- */ int @@ -743,24 +762,23 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjLength -- * - * Retrieve the number of elements in a list. - * - * Value - * - * TCL_OK - * - * A count of list elements is stored at the address provided by - * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is - * converted. - * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An error message will be left in - * the interpreter's result if 'interp' is not NULL. + * This function returns the number of elements in a list object. If the + * object is not already a list object, an attempt will be made to + * convert it to one. + * + * Results: + * The return value is normally TCL_OK; in this case *intPtr will be set + * to the integer count of list elements. If listPtr does not refer to a + * list object and the object can not be converted to one, TCL_ERROR is + * returned and an error message will be left in the interpreter's result + * if interp is not NULL. + * + * Side effects: + * The possible conversion of the argument object to a list object. * *---------------------------------------------------------------------- */ int @@ -792,40 +810,39 @@ /* *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- * - * Replace values in a list. - * - * If 'first' is zero or negative, it refers to the first element. If - * 'first' outside the range of elements in the list, no elements are - * deleted. - * - * If 'count' is zero or negative no elements are deleted, and any new - * elements are inserted at the beginning of the list. - * - * Value - * - * TCL_OK - * - * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr' - * starting at 'first'. If 'objc' 0, no new elements are added. - * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An error message is left in the - * interpreter's result if 'interp' is not NULL. - * - * Effect - * - * If 'listPtr' is not of type 'tclListType', it is converted if possible. - * - * The 'refCount' of each element appended to the list is incremented. - * Similarly, the 'refCount' for each replaced element is decremented. - * - * If 'listPtr' is modified, any previous string representation is - * invalidated. + * This function replaces zero or more elements of the list referenced by + * listPtr with the objects from an (objc,objv) array. The objc elements + * of the array referenced by objv replace the count elements in listPtr + * starting at first. + * + * If the argument first is zero or negative, it refers to the first + * element. If first is greater than or equal to the number of elements + * in the list, then no elements are deleted; the new elements are + * appended to the list. Count gives the number of elements to replace. + * If count is zero or negative then no elements are deleted; the new + * elements are simply inserted before first. + * + * The argument objv refers to an array of objc pointers to the new + * elements to be added to listPtr in place of those that were deleted. + * If objv is NULL, no new elements are added. If listPtr is not a list + * object, an attempt will be made to convert it to one. + * + * Results: + * The return value is normally TCL_OK. If listPtr does not refer to a + * list object and can not be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter's result if interp is + * not NULL. + * + * Side effects: + * The ref counts of the objc elements in objv are incremented since the + * resulting list now refers to them. Similarly, the ref counts for + * replaced objects are decremented. listPtr is converted, if necessary, + * to a list object. listPtr's old string representation, if any, is + * freed. * *---------------------------------------------------------------------- */ int @@ -1079,23 +1096,26 @@ /* *---------------------------------------------------------------------- * * TclLindexList -- * - * Implements the 'lindex' command when objc==3. - * - * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures - * the argument format into required form while taking care to manage - * shimmering so as to tend to keep the most useful intreps - * and/or avoid the most expensive conversions. - * - * Value - * - * A pointer to the specified element, with its 'refCount' incremented, or - * NULL if an error occurred. - * - * Notes + * This procedure handles the 'lindex' command when objc==3. + * + * Results: + * Returns a pointer to the object extracted, or NULL if an error + * occurred. The returned object already includes one reference count for + * the pointer returned. + * + * Side effects: + * None. + * + * Notes: + * This procedure is implemented entirely as a wrapper around + * TclLindexFlat. All it does is reconfigure the argument format into the + * form required by TclLindexFlat, while taking care to manage shimmering + * in such a way that we tend to keep the most useful intreps and/or + * avoid the most expensive conversions. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -1163,24 +1183,29 @@ } /* *---------------------------------------------------------------------- * - * TclLindexFlat -- - * - * The core of the 'lindex' command, with all index - * arguments presented as a flat list. - * - * Value - * - * A pointer to the object extracted, with its 'refCount' incremented, or - * NULL if an error occurred. Thus, the calling code will usually do - * something like: - * - * Tcl_SetObjResult(interp, result); - * Tcl_DecrRefCount(result); - * + * TclLindexFlat -- + * + * This procedure is the core of the 'lindex' command, with all index + * arguments presented as a flat list. + * + * Results: + * Returns a pointer to the object extracted, or NULL if an error + * occurred. The returned object already includes one reference count for + * the pointer returned. + * + * Side effects: + * None. + * + * Notes: + * The reference count of the returned object includes one reference + * corresponding to the pointer returned. Thus, the calling code will + * usually do something like: + * Tcl_SetObjResult(interp, result); + * Tcl_DecrRefCount(result); * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -1252,20 +1277,27 @@ /* *---------------------------------------------------------------------- * * TclLsetList -- * - * The core of [lset] when objc == 4. Objv[2] may be either a + * Core of the 'lset' command when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * - * Implemented entirely as a wrapper around 'TclLindexFlat', as described - * for 'TclLindexList'. + * Results: + * Returns the new value of the list variable, or NULL if there was an + * error. The returned object includes one reference count for the + * pointer returned. * - * Value + * Side effects: + * None. * - * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if - * there was an error. + * Notes: + * This procedure is implemented entirely as a wrapper around + * TclLsetFlat. All it does is reconfigure the argument format into the + * form required by TclLsetFlat, while taking care to manage shimmering + * in such a way that we tend to keep the most useful intreps and/or + * avoid the most expensive conversions. * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -1323,43 +1355,40 @@ * * TclLsetFlat -- * * Core engine of the 'lset' command. * - * Value - * - * The resulting list - * - * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not - * duplicated, its 'refCount' is incremented. The reference count of - * an unduplicated object is therefore 2 (one for the returned pointer - * and one for the variable that holds it). The reference count of a - * duplicate object is 1, reflecting that result is the only active - * reference. The caller is expected to store the result in the - * variable and decrement its reference count. (INST_STORE_* does - * exactly this.) - * - * NULL - * - * An error occurred. If 'listPtr' was duplicated, the reference - * count on the duplicate is decremented so that it is 0, causing any - * memory allocated by this function to be freed. - * - * - * Effect - * - * On entry, the reference count of 'listPtr' does not reflect any - * references held on the stack. The first action of this function is to - * determine whether 'listPtr' is shared and to create a duplicate - * unshared copy if it is. The reference count of the duplicate is - * incremented. At this point, the reference count is 1 in either case so - * that the object is considered unshared. - * - * The unshared list is altered directly to produce the result. - * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string + * Results: + * Returns the new value of the list variable, or NULL if an error + * occurred. The returned object includes one reference count for the + * pointer returned. + * + * Side effects: + * On entry, the reference count of the variable value does not reflect + * any references held on the stack. The first action of this function is + * to determine whether the object is shared, and to duplicate it if it + * is. The reference count of the duplicate is incremented. At this + * point, the reference count will be 1 for either case, so that the + * object will appear to be unshared. + * + * If an error occurs, and the object has been duplicated, the reference + * count on the duplicate is decremented so that it is now 0: this + * dismisses any memory that was allocated by this function. + * + * If no error occurs, the reference count of the original object is + * incremented if the object has not been duplicated, and nothing is done + * to a reference count of the duplicate. Now the reference count of an + * unduplicated object is 2 (the returned pointer, plus the one stored in + * the variable). The reference count of a duplicate object is 1, + * reflecting that the returned pointer is the only active reference. The + * caller is expected to store the returned value back in the variable + * and decrement its reference count. (INST_STORE_* does exactly this.) + * + * Surgery is performed on the unshared list value to produce the result. + * TclLsetFlat maintains a linked list of Tcl_Obj's whose string * representations must be spoilt by threading via 'ptr2' of the - * two-pointer internal representation. On entry to 'TclLsetFlat', the + * two-pointer internal representation. On entry to TclLsetFlat, the * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * *---------------------------------------------------------------------- */ @@ -1570,42 +1599,30 @@ /* *---------------------------------------------------------------------- * * TclListObjSetElement -- * - * Set a single element of a list to a specified value. + * Set a single element of a list to a specified value + * + * Results: + * The return value is normally TCL_OK. If listPtr does not refer to a + * list object and cannot be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter result if interp is + * not NULL. Similarly, if index designates an element outside the range + * [0..listLength-1], where listLength is the count of elements in the + * list object designated by listPtr, TCL_ERROR is returned and an error + * message is left in the interpreter result. + * + * Side effects: + * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts + * to convert it to a list with a non-shared internal rep. Decrements the + * ref count of the object at the specified index within the list, + * replaces with the object designated by valuePtr, and increments the + * ref count of the replacement object. * * It is the caller's responsibility to invalidate the string - * representation of the 'listPtr'. - * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR - * - * 'listPtr' does not refer to a list object and cannot be converted - * to one. An error message will be left in the interpreter result if - * interp is not NULL. - * - * TCL_ERROR - * - * An index designates an element outside the range [0..listLength-1], - * where 'listLength' is the count of elements in the list object - * designated by 'listPtr'. An error message is left in the - * interpreter result. - * - * Effect - * - * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If - * 'listPtr' is not already of type 'tclListType', it is converted and the - * internal representation is unshared. The 'refCount' of the element at - * 'index' is decremented and replaced in the list with the 'valuePtr', - * whose 'refCount' in turn is incremented. - * + * representation of the object. * *---------------------------------------------------------------------- */ int @@ -1719,18 +1736,20 @@ /* *---------------------------------------------------------------------- * * FreeListInternalRep -- * - * Deallocate the storage associated with the internal representation of a - * a list object. - * - * Effect - * - * The storage for the internal 'List' pointer of 'listPtr' is freed, the - * 'internalRep.twoPtrValue.ptr1' of 'listPtr' is set to NULL, and the 'refCount' - * of each element of the list is decremented. + * Deallocate the storage associated with a list object's internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Frees listPtr's List* internal representation and sets listPtr's + * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all + * element objects, which may free them. * *---------------------------------------------------------------------- */ static void @@ -1755,16 +1774,18 @@ /* *---------------------------------------------------------------------- * * DupListInternalRep -- * - * Initialize the internal representation of a list 'Tcl_Obj' to share the + * Initialize the internal representation of a list Tcl_Obj to share the * internal representation of an existing list object. * - * Effect + * Results: + * None. * - * The 'refCount' of the List internal rep is incremented. + * Side effects: + * The reference count of the List internal rep is incremented. * *---------------------------------------------------------------------- */ static void @@ -1780,24 +1801,20 @@ /* *---------------------------------------------------------------------- * * SetListFromAny -- * - * Convert any object to a list. - * - * Value - * - * TCL_OK - * - * Success. The internal representation of 'objPtr' is set, and the type - * of 'objPtr' is 'tclListType'. - * - * TCL_ERROR - * - * An error occured during conversion. An error message is left in the - * interpreter's result if 'interp' is not NULL. - * + * Attempt to generate a list internal form for the Tcl object "objPtr". + * + * Results: + * The return value is TCL_OK or TCL_ERROR. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * If no error occurs, a list is stored as "objPtr"s internal + * representation. * *---------------------------------------------------------------------- */ static int @@ -1918,30 +1935,32 @@ /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * - * Update the string representation for a list object. - * - * Any previously-exising string representation is not invalidated, so - * storage is lost if this has not been taken care of. - * - * Effect - * - * The string representation of 'listPtr' is set to the resulting string. - * This string will be empty if the list has no elements. It is assumed - * that the list internal representation is not NULL. + * Update the string representation for a list object. Note: This + * function does not invalidate an existing old string rep so storage + * will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from the + * list-to-string conversion. This string will be empty if the list has + * no elements. The list internal representation should not be NULL and + * we assume it is not NULL. * *---------------------------------------------------------------------- */ static void UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ { -# define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +# define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; int i, length, bytesNeeded = 0; const char *elem; char *dst; @@ -1974,11 +1993,11 @@ } else { /* * We know numElems <= LIST_MAX, so this is safe. */ - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); Index: generic/tclLiteral.c ================================================================== --- generic/tclLiteral.c +++ generic/tclLiteral.c @@ -184,11 +184,11 @@ int flags, LiteralEntry **globalPtrPtr) { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; - int globalHash; + unsigned int globalHash; Tcl_Obj *objPtr; /* * Is it in the interpreter's global literal table? */ @@ -391,11 +391,12 @@ Interp *iPtr = envPtr->iPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; unsigned hash; - int localHash, objIndex, new; + unsigned int localHash; + int objIndex, new; Namespace *nsPtr; if (length < 0) { length = (bytes ? strlen(bytes) : 0); } @@ -535,11 +536,12 @@ int index) /* The index of the entry in the literal * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; - int localHash, length; + unsigned int localHash; + int length; const char *bytes; Tcl_Obj *newObjPtr; lPtr = &envPtr->literalArrayPtr[index]; @@ -554,11 +556,11 @@ Tcl_IncrRefCount(newObjPtr); TclReleaseLiteral(interp, lPtr->objPtr); lPtr->objPtr = newObjPtr; bytes = TclGetStringFromObj(newObjPtr, &length); - localHash = (HashString(bytes, length) & localTablePtr->mask); + localHash = HashString(bytes, length) & localTablePtr->mask; nextPtrPtr = &localTablePtr->buckets[localHash]; for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { if (entryPtr == lPtr) { *nextPtrPtr = lPtr->nextPtr; @@ -610,11 +612,11 @@ envPtr->literalArrayNext++; lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); - lPtr->refCount = -1; /* i.e., unused */ + lPtr->refCount = (size_t)-1; /* i.e., unused */ lPtr->nextPtr = NULL; if (litPtrPtr) { *litPtrPtr = lPtr; } @@ -807,11 +809,12 @@ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; - int length, index; + int length; + unsigned int index; if (iPtr == NULL) { goto done; } @@ -826,19 +829,17 @@ */ for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index]; entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { - entryPtr->refCount--; - /* * If the literal is no longer being used by any ByteCode, delete * the entry then remove the reference corresponding to the global * literal table entry (decrement the ref count of the object). */ - if (entryPtr->refCount == 0) { + if (entryPtr->refCount-- <= 1) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { prevPtr->nextPtr = entryPtr->nextPtr; } @@ -952,12 +953,12 @@ LiteralEntry **oldBuckets; register LiteralEntry **oldChainPtr, **newChainPtr; register LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; - unsigned int oldSize; - int count, index, length; + unsigned int oldSize, index; + int count, length; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; /* Index: generic/tclLoad.c ================================================================== --- generic/tclLoad.c +++ generic/tclLoad.c @@ -468,21 +468,10 @@ * Test for whether the initialization failed. If so, transfer the error * from the target interpreter to the originating one. */ if (code != TCL_OK) { - Interp *iPtr = (Interp *) target; - if (iPtr->legacyResult && !iPtr->legacyFreeProc) { - /* - * A call to Tcl_InitStubs() determined the caller extension and - * this interp are incompatible in their stubs mechanisms, and - * recorded the error in the oldest legacy place we have to do so. - */ - Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, -1)); - iPtr->legacyResult = NULL; - iPtr->legacyFreeProc = (void (*) (void))-1; - } Tcl_TransferResult(target, code, interp); goto done; } /* Index: generic/tclMain.c ================================================================== --- generic/tclMain.c +++ generic/tclMain.c @@ -264,22 +264,18 @@ * Test for the existence of the rc file before trying to read it. */ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != NULL) { - Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1); - Tcl_Close(NULL, c); - Tcl_IncrRefCount(fullNameObj); - if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) { + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } - Tcl_DecrRefCount(fullNameObj); } } Tcl_DStringFree(&temp); } } Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -30,11 +30,11 @@ * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. */ typedef struct { - size_t numNsCreated; /* Count of the number of namespaces created + unsigned long numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a * unique id for each namespace. Cannot be * per-interp because the nsId is used to * distinguish objects which can be passed * around between interps in the same thread, @@ -400,11 +400,11 @@ ckfree(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); - if (--framePtr->localCachePtr->refCount == 0) { + if (framePtr->localCachePtr->refCount-- <= 1) { TclFreeLocalCache(interp, framePtr->localCachePtr); } framePtr->localCachePtr = NULL; } @@ -913,10 +913,15 @@ TclGetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Command *cmdPtr; + /* + * Ensure that this namespace doesn't get deallocated in the meantime. + */ + nsPtr->refCount++; + /* * Give anyone interested - notably TclOO - a chance to use this namespace * normally despite the fact that the namespace is going to go. Allows the * calling of destructors. Will only be called once (unless re-established * by the called function). [Bug 2950259] @@ -1045,20 +1050,11 @@ ckfree(nsPtr->childTablePtr); } #endif Tcl_DeleteHashTable(&nsPtr->cmdTable); - /* - * If the reference count is 0, then discard the namespace. - * Otherwise, mark it as "dead" so that it can't be used. - */ - - if (nsPtr->refCount == 0) { - NamespaceFree(nsPtr); - } else { - nsPtr->flags |= NS_DEAD; - } + nsPtr ->flags |= NS_DEAD; } else { /* * Restore the ::errorInfo and ::errorCode traces. */ @@ -1071,10 +1067,11 @@ */ nsPtr->flags &= ~(NS_DYING|NS_KILLED); } } + TclNsDecrRefCount(nsPtr); } /* *---------------------------------------------------------------------- * @@ -2422,10 +2419,39 @@ } /* *---------------------------------------------------------------------- * + * TclEnsureNamespace -- + * + * Provide a namespace that is not deleted. + * + * Value + * + * namespacePtr, if it is not scheduled for deletion, or a pointer to a + * new namespace with the same name otherwise. + * + * Effect + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Namespace * +TclEnsureNamespace( + Tcl_Interp *interp, + Tcl_Namespace *namespacePtr) +{ + Namespace *nsPtr = (Namespace *) namespacePtr; + if (!(nsPtr->flags & NS_DYING)) { + return namespacePtr; + } + return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_FindNamespace -- * * Searches for a namespace. * * Results: @@ -2636,11 +2662,11 @@ } } else { Namespace *nsPtr[2]; register int search; - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + TclGetNamespaceForQualName(interp, name, cxtNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the command in the command table of its namespace. Be sure * to check both possible search paths: from the specified namespace Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ generic/tclOO.c @@ -2,10 +2,11 @@ * tclOO.c -- * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2017 by Nathan Coulter * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ @@ -56,13 +57,11 @@ * Function declarations for things defined in this file. */ static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, - const char *nsNameStr); -static void ClearMixins(Class *clsPtr); -static void ClearSuperclasses(Class *clsPtr); + Namespace *nsPtr, const char *nsNameStr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr, Method **newMPtrPtr); static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, Method *mPtr, Tcl_Obj *namePtr); @@ -70,21 +69,26 @@ static void DeletedObjdefNamespace(ClientData clientData); 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); static void MyDeleted(ClientData clientData); static void ObjectNamespaceDeleted(ClientData clientData); 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 void SquelchedNsFirst(ClientData clientData); static int PublicObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int PublicNRObjectCmd(ClientData clientData, @@ -226,14 +230,56 @@ * either an oPtr or a classPtr. Note that the roots oo::object and oo::class * have _both_ their object and class flags tagged with ROOT_OBJECT and * 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; +} /* * ---------------------------------------------------------------------- * * TclOOInit -- @@ -373,32 +419,14 @@ } 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, "::oo::object", NULL)); - fPtr->classCls = AllocClass(interp, - AllocObject(interp, "::oo::class", 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. */ @@ -461,10 +489,92 @@ if (TclOODefineSlots(fPtr) != TCL_OK) { return TCL_ERROR; } 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. + */ +} /* * ---------------------------------------------------------------------- * * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace -- @@ -520,12 +630,10 @@ Tcl_Interp *interp) /* The interpreter containing the OO system * foundation. */ { Foundation *fPtr = GetFoundation(interp); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->objectCls); TclDecrRefCount(fPtr->unknownMethodNameObj); TclDecrRefCount(fPtr->constructorName); TclDecrRefCount(fPtr->destructorName); TclDecrRefCount(fPtr->clonedName); TclDecrRefCount(fPtr->defineName); @@ -536,12 +644,15 @@ * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- */ static Object * @@ -550,10 +661,12 @@ * object. */ const char *nameStr, /* The name of the object to create, or NULL * 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 */ 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 * a namespace that already exists, the effect * will be the same as if this was NULL. */ @@ -560,11 +673,11 @@ { Foundation *fPtr = GetFoundation(interp); Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; - int creationEpoch, ignored; + int creationEpoch; oPtr = ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); /* @@ -578,12 +691,11 @@ * names using the epoch until such time as a new namespace is actually * created. */ if (nsNameStr != NULL) { - oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, - ObjectNamespaceDeleted); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = ++fPtr->tsdPtr->nsCount; goto configNamespace; } Tcl_ResetResult(interp); @@ -591,12 +703,11 @@ while (1) { char objName[10 + TCL_INTEGER_SPACE]; sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); - oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, - ObjectNamespaceDeleted); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = fPtr->tsdPtr->nsCount; break; } @@ -632,46 +743,44 @@ * Set up a callback to get notification of the deletion of a namespace * when enough of the namespace still remains to execute commands and * access variables in it. [Bug 2950259] */ - ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst; + ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = ObjectNamespaceDeleted; /* * Fill in the rest of the non-zero/NULL parts of the structure. */ 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; /* * Finally, create the object commands and initialize the trace on the * public command (so that the object structures are deleted when the * command is deleted). */ if (!nameStr) { - oPtr->command = Tcl_CreateObjCommand(interp, - oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL); - } else if (nameStr[0] == ':' && nameStr[1] == ':') { - oPtr->command = Tcl_CreateObjCommand(interp, nameStr, - PublicObjectCmd, oPtr, NULL); - } else { - Tcl_DString buffer; - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, - Tcl_GetCurrentNamespace(interp)->fullName, -1); - TclDStringAppendLiteral(&buffer, "::"); - Tcl_DStringAppend(&buffer, nameStr, -1); - oPtr->command = Tcl_CreateObjCommand(interp, - Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL); - Tcl_DStringFree(&buffer); - } + nameStr = oPtr->namespacePtr->name; + nsPtr = (Namespace *)oPtr->namespacePtr; + if (nsPtr->parentPtr != NULL) { + nsPtr = nsPtr->parentPtr; + } + + } + oPtr->command = TclCreateObjCommandInNs(interp, nameStr, + (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL); /* * Add the NRE command and trace directly. While this breaks a number of * abstractions, it is faster and we're inside Tcl here so we're allowed. */ @@ -683,30 +792,12 @@ tracePtr->clientData = oPtr; tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; 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; } /* * ---------------------------------------------------------------------- @@ -753,34 +844,10 @@ } /* * ---------------------------------------------------------------------- * - * SquelchedNsFirst -- - * - * This callback is triggered when the object's namespace is deleted by - * any mechanism. It deletes the object's public command if it has not - * already been deleted, so ensuring that destructors get run at an - * appropriate time. [Bug 2950259] - * - * ---------------------------------------------------------------------- - */ - -static void -SquelchedNsFirst( - ClientData clientData) -{ - Object *oPtr = clientData; - - if (oPtr->command) { - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); - } -} - -/* - * ---------------------------------------------------------------------- - * * ObjectRenamedTrace -- * * This callback is triggered when the object is deleted by any * mechanism. It runs the destructors and arranges for the actual cleanup * of the object's namespace, which in turn triggers cleansing of the @@ -796,11 +863,10 @@ const char *oldName, /* What the object was (last) called. */ const char *newName, /* What it's getting renamed to. (unused) */ int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; - Foundation *fPtr = oPtr->fPtr; /* * If this is a rename and not a delete of the object, we just flush the * cache of the object name. */ @@ -808,164 +874,102 @@ if (flags & TCL_TRACE_RENAME) { SquelchCachedName(oPtr); return; } - /* - * Oh dear, the object really is being deleted. Handle this by running the - * destructors and deleting the object's namespace, which in turn causes - * the real object structures to be deleted. - * - * Note that it is possible for the namespace to be deleted before the - * command. Because of that case, we must take care here to mark the - * command as being deleted so that if we return here we don't run into - * reentrancy problems. - * - * We also do not run destructors on the core class objects when the - * interpreter is being deleted; their incestuous nature causes problems - * in that case when the destructor is partially deleted before the uses - * of it have gone. [Bug 2949397] - */ - - AddRef(oPtr); - AddRef(fPtr->classCls); - AddRef(fPtr->objectCls); - AddRef(fPtr->classCls->thisPtr); - AddRef(fPtr->objectCls->thisPtr); - oPtr->command = NULL; - - if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { - 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; - state = Tcl_SaveInterpState(interp, TCL_OK); - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, - contextPtr, 0, NULL); - if (result != TCL_OK) { - Tcl_BackgroundException(interp, result); - } - Tcl_RestoreInterpState(interp, state); - TclOODeleteContext(contextPtr); - } - } - - /* - * OK, the destructor's been run. Time to splat the class data (if any) - * and nuke the namespace (which triggers the final crushing of the object - * structure itself). - * - * 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)) { - Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); - } - - if (oPtr->classPtr != NULL) { - AddRef(oPtr->classPtr); - ReleaseClassContents(interp, oPtr); - } - /* * The namespace is only deleted if it hasn't already been deleted. [Bug - * 2950259] + * 2950259]. */ - if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { + if (!Deleted(oPtr)) { Tcl_DeleteNamespace(oPtr->namespacePtr); } - if (oPtr->classPtr) { - DelRef(oPtr->classPtr); - } - DelRef(fPtr->classCls->thisPtr); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->classCls); - DelRef(fPtr->objectCls); - DelRef(oPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * ClearMixins, ClearSuperclasses -- - * - * Utility functions for correctly clearing the list of mixins or - * superclasses of a class. Will ckfree() the list storage. - * - * ---------------------------------------------------------------------- - */ - -static void -ClearMixins( - Class *clsPtr) -{ - int i; - Class *mixinPtr; - - if (clsPtr->mixins.num == 0) { - return; - } - - FOREACH(mixinPtr, clsPtr->mixins) { - TclOORemoveFromMixinSubs(clsPtr, mixinPtr); - } - ckfree(clsPtr->mixins.list); - clsPtr->mixins.list = NULL; - clsPtr->mixins.num = 0; -} - -static void -ClearSuperclasses( - Class *clsPtr) -{ - int i; - Class *superPtr; - - if (clsPtr->superclasses.num == 0) { - return; - } - - FOREACH(superPtr, clsPtr->superclasses) { - TclOORemoveFromSubclasses(clsPtr, superPtr); - } - ckfree(clsPtr->superclasses.list); - clsPtr->superclasses.list = NULL; - clsPtr->superclasses.num = 0; -} - -/* - * ---------------------------------------------------------------------- - * - * ReleaseClassContents -- + oPtr->command = NULL; + TclOODecrRefCount(oPtr); + return; +} + +/* + * ---------------------------------------------------------------------- + * + * DeleteDescendants, ReleaseClassContents -- * * Tear down the special class data structure, including deleting all * dependent classes and objects. * * ---------------------------------------------------------------------- */ + +static void +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; + + /* + * Squelch classes that this class has been mixed into. + */ + + FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { + /* + * This condition also covers the case where mixinSubclassPtr == + * clsPtr + */ + + if (!Deleted(mixinSubclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); + } + i -= TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); + TclOODecrRefCount(mixinSubclassPtr->thisPtr); + } + + /* + * Squelch subclasses of this class. + */ + + FOREACH(subclassPtr, clsPtr->subclasses) { + if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) { + Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); + } + i -= TclOORemoveFromSubclasses(subclassPtr, clsPtr); + TclOODecrRefCount(subclassPtr->thisPtr); + } + + /* + * 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); + } + } +} static void ReleaseClassContents( Tcl_Interp *interp, /* The interpreter containing the class. */ Object *oPtr) /* The object representing the class. */ { 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; /* * Sanity check! */ @@ -980,130 +984,10 @@ Tcl_Panic("deleting class structure for non-deleted %s", "general object"); } } - /* - * 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) { - int j; - if (instancePtr->selfCls == clsPtr) { - instancePtr->flags |= CLASS_GONE; - } - for(j=0 ; jmixins.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 (!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 == 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. */ if (clsPtr->constructorChainPtr) { @@ -1152,10 +1036,35 @@ } Tcl_DeleteHashTable(clsPtr->metadataPtr); ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } + + FOREACH(tmpClsPtr, clsPtr->mixins) { + TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); + } + FOREACH(tmpClsPtr, clsPtr->superclasses) { + TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); + } + + FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(&clsPtr->classMethods); + TclOODelMethodRef(clsPtr->constructorPtr); + TclOODelMethodRef(clsPtr->destructorPtr); + + FOREACH(variableObj, clsPtr->variables) { + TclDecrRefCount(variableObj); + } + if (i) { + ckfree(clsPtr->variables.list); + } + + if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); + } } /* * ---------------------------------------------------------------------- * @@ -1173,52 +1082,107 @@ ObjectNamespaceDeleted( ClientData clientData) /* Pointer to the class whose namespace is * being deleted. */ { Object *oPtr = clientData; + Foundation *fPtr = oPtr->fPtr; FOREACH_HASH_DECLS; - Class *clsPtr = oPtr->classPtr, *mixinPtr; + Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; - int deleteAlreadyInProgress = 0, i; + Tcl_Interp *interp = oPtr->fPtr->interp; + int i; + + if (Deleted(oPtr)) { + /* + * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this + * guard could be removed. + */ + + return; + } + + /* + * 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 + * interpreter is being deleted; their incestuous nature causes problems + * in that case when the destructor is partially deleted before the uses + * of it have gone. [Bug 2949397] + */ + + 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; + state = Tcl_SaveInterpState(interp, TCL_OK); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, + contextPtr, 0, NULL); + if (result != TCL_OK) { + Tcl_BackgroundException(interp, result); + } + Tcl_RestoreInterpState(interp, state); + TclOODeleteContext(contextPtr); + } + } /* * Instruct everyone to no longer use any allocated fields of the object. - * Also delete the commands that refer to the object at this point (if - * they still exist) because otherwise their references to the object - * point into freed memory, allowing crashes. + * Also delete the command that refers to the object at this point (if + * it still exists) because otherwise its pointer to the object + * points into freed memory. */ - if (oPtr->command) { - if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { - /* - * Namespace deletion must have been triggered by a trace on command - * deletion , meaning that ObjectRenamedTrace() is eventually going - * to be called . - */ - deleteAlreadyInProgress = 1; - } + 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, + */ + } else { + /* + * The namespace must have been deleted directly. Delete the command + * as well. + */ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } + if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } /* * Splice the object out of its context. After this, we must *not* call * 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) { - TclOORemoveFromInstances(oPtr, mixinPtr); - } + i -= TclOORemoveFromInstances(oPtr, mixinPtr); } if (i) { ckfree(oPtr->mixins.list); } @@ -1261,82 +1225,71 @@ ckfree(oPtr->metadataPtr); oPtr->metadataPtr = NULL; } /* - * If this was a class, there's additional deletion work to do. + * 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 (clsPtr != NULL) { - Tcl_ObjectMetadataType *metadataTypePtr; - ClientData value; - - if (clsPtr->metadataPtr != NULL) { - FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { - metadataTypePtr->deleteProc(value); - } - Tcl_DeleteHashTable(clsPtr->metadataPtr); - ckfree(clsPtr->metadataPtr); - clsPtr->metadataPtr = NULL; - } - - FOREACH(filterObj, clsPtr->filters) { - TclDecrRefCount(filterObj); - } - if (i) { - ckfree(clsPtr->filters.list); - clsPtr->filters.num = 0; - } - - ClearMixins(clsPtr); - - ClearSuperclasses(clsPtr); - - if (clsPtr->subclasses.list) { - ckfree(clsPtr->subclasses.list); - clsPtr->subclasses.list = NULL; - clsPtr->subclasses.num = 0; - } - if (clsPtr->instances.list) { - ckfree(clsPtr->instances.list); - clsPtr->instances.list = NULL; - clsPtr->instances.num = 0; - } - if (clsPtr->mixinSubs.list) { - ckfree(clsPtr->mixinSubs.list); - clsPtr->mixinSubs.list = NULL; - clsPtr->mixinSubs.num = 0; - } - - FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { - TclOODelMethodRef(mPtr); - } - Tcl_DeleteHashTable(&clsPtr->classMethods); - TclOODelMethodRef(clsPtr->constructorPtr); - TclOODelMethodRef(clsPtr->destructorPtr); - - FOREACH(variableObj, clsPtr->variables) { - TclDecrRefCount(variableObj); - } - if (i) { - ckfree(clsPtr->variables.list); - } - - DelRef(clsPtr); + if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) + && !Tcl_InterpDeleted(interp)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); + } + + if (oPtr->classPtr != NULL) { + ReleaseClassContents(interp, oPtr); } /* * Delete the object structure itself. */ - if (deleteAlreadyInProgress) { - oPtr->classPtr = NULL; - oPtr->namespacePtr = NULL; - } else { - DelRef(oPtr); + oPtr->namespacePtr = NULL; + 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; } /* * ---------------------------------------------------------------------- * @@ -1346,40 +1299,32 @@ * a class. * * ---------------------------------------------------------------------- */ -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; + + if (Deleted(clsPtr->thisPtr)) { + return res; + } FOREACH(instPtr, clsPtr->instances) { if (oPtr == instPtr) { - goto removeInstance; - } - } - 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]; - } - clsPtr->instances.list[clsPtr->instances.num] = NULL; - } + RemoveItem(Object, clsPtr->instances, i); + TclOODecrRefCount(oPtr); + res++; + break; + } + } + return res; } /* * ---------------------------------------------------------------------- * @@ -1396,13 +1341,10 @@ Object *oPtr, /* The instance to add. */ Class *clsPtr) /* The class to add the instance to. It is * 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) { clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK); } else { @@ -1409,48 +1351,45 @@ clsPtr->instances.list = ckrealloc(clsPtr->instances.list, sizeof(Object *) * clsPtr->instances.size); } } clsPtr->instances.list[clsPtr->instances.num++] = oPtr; + AddRef(oPtr); } /* * ---------------------------------------------------------------------- * * 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 + Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i; + int i, res = 0; Class *subclsPtr; + + if (Deleted(superPtr->thisPtr)) { + return res; + } FOREACH(subclsPtr, superPtr->subclasses) { if (subPtr == subclsPtr) { - goto removeSubclass; + RemoveItem(Class, superPtr->subclasses, i); + TclOODecrRefCount(subPtr->thisPtr); + 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]; - } - superPtr->subclasses.list[superPtr->subclasses.num] = NULL; - } + return res; } /* * ---------------------------------------------------------------------- * @@ -1473,17 +1412,18 @@ return; } 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); } /* * ---------------------------------------------------------------------- * @@ -1493,35 +1433,32 @@ * another class. * * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromMixinSubs( Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to (possibly) remove the + Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i; + int i, res = 0; Class *subclsPtr; + + if (Deleted(superPtr->thisPtr)) { + return res; + } FOREACH(subclsPtr, superPtr->mixinSubs) { if (subPtr == subclsPtr) { - goto removeSubclass; + RemoveItem(Class, superPtr->mixinSubs, i); + TclOODecrRefCount(subPtr->thisPtr); + res++; + break; } } - return; - - removeSubclass: - if (!Deleted(superPtr->thisPtr)) { - superPtr->mixinSubs.num--; - if (i < superPtr->mixinSubs.num) { - superPtr->mixinSubs.list[i] = - superPtr->mixinSubs.list[superPtr->mixinSubs.num]; - } - superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL; - } + return res; } /* * ---------------------------------------------------------------------- * @@ -1551,48 +1488,30 @@ superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list, sizeof(Class *) * superPtr->mixinSubs.size); } } superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; + AddRef(subPtr->thisPtr); } /* * ---------------------------------------------------------------------- * * 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); - } else { - clsPtr->thisPtr = useThisObj; - } - - /* - * Configure the namespace path for the class's object. - */ if (fPtr->helpersNs != NULL) { Tcl_Namespace *path[2]; path[0] = fPtr->helpersNs; @@ -1600,26 +1519,40 @@ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); } else { 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 * objects. */ 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. */ @@ -1628,11 +1561,10 @@ /* * That's the complicated bit. Now fill in the rest of the non-zero/NULL * fields. */ - clsPtr->refCount = 1; Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; } /* @@ -1642,11 +1574,10 @@ * * Allocate a new instance of an object. * * ---------------------------------------------------------------------- */ - Tcl_Object Tcl_NewObjectInstance( Tcl_Interp *interp, /* Interpreter context. */ Tcl_Class cls, /* Class to create an instance of. */ const char *nameStr, /* Name of object to create, or NULL to ask @@ -1659,58 +1590,21 @@ Tcl_Obj *const *objv, /* Argument list. */ int skip) /* Number of arguments to _not_ pass to the * constructor. */ { register Class *classPtr = (Class *) cls; - Foundation *fPtr = GetFoundation(interp); Object *oPtr; - - /* - * Check if we're going to create an object over an existing command; - * that's not allowed. - */ - - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - 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); + ClientData clientData[4]; + + oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); + if (oPtr == NULL) { return NULL; } /* - * Create the object. - */ - - oPtr = AllocObject(interp, nameStr, nsNameStr); - oPtr->selfCls = classPtr; - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. - */ - - AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } else { - oPtr->classPtr = NULL; - } - - /* - * Run constructors, except when objc < 0 (a special flag case used for - * object cloning only). + * Run constructors, except when objc < 0, which is a special flag case + * used for object cloning only. */ if (objc >= 0) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); @@ -1722,11 +1616,11 @@ state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; 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); result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, objv); @@ -1733,40 +1627,19 @@ if (isRoot) { TclResetRewriteEnsemble(interp, 1); } - /* - * It's an error if the object was whacked in the constructor. - * Force this if it isn't already an error (don't want to lose - * errors by accident...) [Bug 2903011] - */ - - if (result != TCL_ERROR && Deleted(oPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "object deleted in constructor", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); - result = TCL_ERROR; - } - TclOODeleteContext(contextPtr); - if (result != TCL_OK) { - Tcl_DiscardInterpState(state); - - /* - * Take care to not delete a deleted object; that would be - * bad. [Bug 2903011] Also take care to make sure that we have - * the name of the command before we delete it. [Bug - * 9dd1bd7a74] - */ - - if (!Deleted(oPtr)) { - (void) TclOOObjectName(interp, oPtr); - Tcl_DeleteCommandFromToken(interp, oPtr->command); - } + clientData[0] = contextPtr; + clientData[1] = oPtr; + clientData[2] = state; + clientData[3] = &oPtr; + + result = FinalizeAlloc(clientData, interp, result); + if (result != TCL_OK) { return NULL; } - Tcl_RestoreInterpState(interp, state); } } return (Tcl_Object) oPtr; } @@ -1787,55 +1660,19 @@ * constructor. */ Tcl_Object *objectPtr) /* Place to write the object reference upon * successful allocation. */ { register Class *classPtr = (Class *) cls; - Foundation *fPtr = GetFoundation(interp); CallContext *contextPtr; Tcl_InterpState state; Object *oPtr; - /* - * Check if we're going to create an object over an existing command; - * that's not allowed. - */ - - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - 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); + oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); + if (oPtr == NULL) { return TCL_ERROR; } - /* - * Create the object. - */ - - oPtr = AllocObject(interp, nameStr, nsNameStr); - oPtr->selfCls = classPtr; - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. - */ - - AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } - /* * Run constructors, except when objc < 0 (a special flag case used for * object cloning only). If there aren't any constructors, we do nothing. */ @@ -1852,11 +1689,11 @@ state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; contextPtr->skip = skip; /* - * Adjust the ensmble tracking record if necessary. [Bug 3514761] + * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ if (TclInitRewriteEnsemble(interp, skip, skip, objv)) { TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } @@ -1863,16 +1700,87 @@ /* * Fire off the constructors non-recursively. */ - AddRef(oPtr); TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, objectPtr); TclPushTailcallPoint(interp); return TclOOInvokeContext(contextPtr, interp, objc, objv); } + + +Object * +TclNewObjectInstanceCommon( + Tcl_Interp *interp, + Class *classPtr, + const char *nameStr, + const char *nsNameStr) +{ + Tcl_HashEntry *hPtr; + Foundation *fPtr = GetFoundation(interp); + Object *oPtr; + const char *simpleName = NULL; + 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); + + /* + * Disallow creation of an object over an existing command. + */ + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew); + 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. + */ + + oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); + oPtr->selfCls = classPtr; + TclOOAddToInstances(oPtr, classPtr); + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable(fPtr->classCls, classPtr)) { + /* + * Is a class, so attach a class structure. Note that the AllocClass + * function splices the structure into the object, so we don't have + * to. Once that's done, we need to repatch the object to have the + * right class since AllocClass interferes with that. + */ + + AllocClass(interp, oPtr); + TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } else { + oPtr->classPtr = NULL; + } + return oPtr; +} + + static int FinalizeAlloc( ClientData data[], Tcl_Interp *interp, @@ -1882,22 +1790,20 @@ Object *oPtr = data[1]; Tcl_InterpState state = data[2]; Tcl_Object *objectPtr = data[3]; /* - * It's an error if the object was whacked in the constructor. Force this - * if it isn't already an error (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)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object deleted in constructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); result = TCL_ERROR; } - TclOODeleteContext(contextPtr); if (result != TCL_OK) { Tcl_DiscardInterpState(state); /* * Take care to not delete a deleted object; that would be bad. [Bug @@ -1907,16 +1813,26 @@ if (!Deleted(oPtr)) { (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; } /* * ---------------------------------------------------------------------- @@ -2021,11 +1937,10 @@ * call. */ o2Ptr->flags = oPtr->flags & ~( OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); - /* * Copy the object's metadata. */ if (oPtr->metadataPtr != NULL) { @@ -3033,11 +2948,11 @@ int Tcl_ObjectDeleted( Tcl_Object object) { - return Deleted(object) ? 1 : 0; + return ((Object *)object)->command == NULL; } Tcl_Object Tcl_GetClassAsObject( Tcl_Class clazz) Index: generic/tclOOBasic.c ================================================================== --- generic/tclOOBasic.c +++ generic/tclOOBasic.c @@ -1204,26 +1204,14 @@ if (objc == 2) { o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL); } else { const char *name, *namespaceName; - Tcl_DString buffer; name = TclGetString(objv[2]); - Tcl_DStringInit(&buffer); if (name[0] == '\0') { name = NULL; - } else if (name[0]!=':' || name[1]!=':') { - Interp *iPtr = (Interp *) interp; - - if (iPtr->varFramePtr != NULL) { - Tcl_DStringAppend(&buffer, - iPtr->varFramePtr->nsPtr->fullName, -1); - } - TclDStringAppendLiteral(&buffer, "::"); - Tcl_DStringAppend(&buffer, name, -1); - name = Tcl_DStringValue(&buffer); } /* * Choose a unique namespace name if the user didn't supply one. */ @@ -1241,11 +1229,10 @@ return TCL_ERROR; } } o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName); - Tcl_DStringFree(&buffer); } if (o2Ptr == NULL) { return TCL_ERROR; } Index: generic/tclOOCall.c ================================================================== --- generic/tclOOCall.c +++ generic/tclOOCall.c @@ -108,11 +108,16 @@ register Object *oPtr = contextPtr->oPtr; TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); - DelRef(oPtr); + + /* + * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore + */ + + TclOODecrRefCount(oPtr); } } /* * ---------------------------------------------------------------------- @@ -898,10 +903,11 @@ /* * ---------------------------------------------------------------------- * * 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: * - Refers to the same object (same creation epoch), and * - Still across the same class structure (same global epoch), and @@ -1169,10 +1175,15 @@ } returnContext: contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; + + /* + * Corresponding TclOODecrRefCount() in TclOODeleteContext + */ + AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; contextPtr->index = 0; return contextPtr; Index: generic/tclOODefineCmds.c ================================================================== --- generic/tclOODefineCmds.c +++ generic/tclOODefineCmds.c @@ -121,10 +121,11 @@ /* * ---------------------------------------------------------------------- * * 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 * the worst case, the simplest option is to advance the global epoch, * causing *everything* to be thrown away on next usage. @@ -165,10 +166,11 @@ /* * ---------------------------------------------------------------------- * * RecomputeClassCacheFlag -- + * * Determine whether the object is prototypical of its class, and hence * able to use the class's method chain cache. * * ---------------------------------------------------------------------- */ @@ -187,10 +189,11 @@ /* * ---------------------------------------------------------------------- * * TclOOObjectSetFilters -- + * * Install a list of filter method names into an object. * * ---------------------------------------------------------------------- */ @@ -245,10 +248,11 @@ /* * ---------------------------------------------------------------------- * * TclOOClassSetFilters -- + * * Install a list of filter method names into a class. * * ---------------------------------------------------------------------- */ @@ -307,10 +311,11 @@ /* * ---------------------------------------------------------------------- * * TclOOObjectSetMixins -- + * * Install a list of mixin classes into an object. * * ---------------------------------------------------------------------- */ @@ -324,13 +329,11 @@ int i; 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; } RecomputeClassCacheFlag(oPtr); @@ -350,10 +353,17 @@ oPtr->mixins.num = numMixins; memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); + + /* + * Corresponding TclOODecrRefCount() is in the caller of this + * function. + */ + + TclOODecrRefCount(mixinPtr->thisPtr); } } } oPtr->epoch++; } @@ -360,10 +370,11 @@ /* * ---------------------------------------------------------------------- * * TclOOClassSetMixins -- + * * Install a list of mixin classes into a class. * * ---------------------------------------------------------------------- */ @@ -397,19 +408,27 @@ } classPtr->mixins.num = numMixins; 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); } /* * ---------------------------------------------------------------------- * * RenameDeleteMethod -- + * * Core of the code to rename and delete methods. * * ---------------------------------------------------------------------- */ @@ -495,10 +514,11 @@ /* * ---------------------------------------------------------------------- * * 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 * prefix of. * @@ -573,10 +593,11 @@ /* * ---------------------------------------------------------------------- * * FindCommand -- + * * Specialized version of Tcl_FindCommand that handles command prefixes * and disallows namespace magic. * * ---------------------------------------------------------------------- */ @@ -633,10 +654,11 @@ /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- @@ -658,11 +680,13 @@ -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); 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); framePtr->clientData = oPtr; framePtr->objc = objc; @@ -673,10 +697,11 @@ /* * ---------------------------------------------------------------------- * * TclOOGetDefineCmdContext -- + * * Extracts the magic token from the current stack frame, or returns NULL * (and leaves an error message) otherwise. * * ---------------------------------------------------------------------- */ @@ -709,10 +734,11 @@ /* * ---------------------------------------------------------------------- * * 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 * definitions at. * @@ -751,10 +777,11 @@ /* * ---------------------------------------------------------------------- * * GenerateErrorInfo -- + * * Factored out code to generate part of the error trace messages. * * ---------------------------------------------------------------------- */ @@ -789,10 +816,11 @@ /* * ---------------------------------------------------------------------- * * 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 * clearer. Doesn't handle the management of the stack frame. * @@ -852,10 +880,11 @@ /* * ---------------------------------------------------------------------- * * 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 * namespace. Also does ensemble-like tricks with dispatch so that error * messages are clearer. @@ -912,11 +941,11 @@ } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. */ @@ -926,10 +955,11 @@ /* * ---------------------------------------------------------------------- * * 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 * namespace. Also does ensemble-like tricks with dispatch so that error * messages are clearer. @@ -979,11 +1009,11 @@ } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. */ @@ -993,10 +1023,11 @@ /* * ---------------------------------------------------------------------- * * 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 * commands in the target namespace. Also does ensemble-like tricks with * dispatch so that error messages are clearer. @@ -1046,11 +1077,11 @@ } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. */ @@ -1060,10 +1091,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineObjSelfObjCmd -- + * * Implementation of the "self" subcommand of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ @@ -1093,10 +1125,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineClassObjCmd -- + * * Implementation of the "class" subcommand of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ @@ -1166,15 +1199,18 @@ * Set the object's class. */ 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 { oPtr->epoch++; } @@ -1184,10 +1220,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineConstructorObjCmd -- + * * Implementation of the "constructor" subcommand of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -1252,10 +1289,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineDeleteMethodObjCmd -- + * * Implementation of the "deletemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1308,10 +1346,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineDestructorObjCmd -- + * * Implementation of the "destructor" subcommand of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -1372,10 +1411,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineExportObjCmd -- + * * Implementation of the "export" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1466,10 +1506,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineForwardObjCmd -- + * * Implementation of the "forward" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1526,10 +1567,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineMethodObjCmd -- + * * Implementation of the "method" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1583,10 +1625,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineMixinObjCmd -- + * * Implementation of the "mixin" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1626,10 +1669,17 @@ "may not mix a class into itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); 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) { TclOOObjectSetMixins(oPtr, objc-1, mixins); } else { @@ -1638,18 +1688,22 @@ TclStackFree(interp, mixins); return TCL_OK; freeAndError: + while (--i > 0) { + TclOODecrRefCount(mixins[i]->thisPtr); + } TclStackFree(interp, mixins); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * TclOODefineRenameMethodObjCmd -- + * * Implementation of the "renamemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1702,10 +1756,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- + * * Implementation of the "unexport" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ @@ -1796,10 +1851,11 @@ /* * ---------------------------------------------------------------------- * * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- + * * How to install a constructor or destructor into a class; API to call * from C. * * ---------------------------------------------------------------------- */ @@ -1850,10 +1906,11 @@ /* * ---------------------------------------------------------------------- * * TclOODefineSlots -- + * * Create the "::oo::Slot" class and its standard instances. Class * definition is empty at the stage (added by scripting). * * ---------------------------------------------------------------------- */ @@ -1893,10 +1950,11 @@ /* * ---------------------------------------------------------------------- * * ClassFilterGet, ClassFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -1972,10 +2030,11 @@ /* * ---------------------------------------------------------------------- * * ClassMixinGet, ClassMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -2053,33 +2112,45 @@ for (i=0 ; iclassPtr, mixins[i])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not mix a class into itself", -1)); 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); TclStackFree(interp, mixins); return TCL_OK; freeAndError: + while (i-- > 0) { + TclOODecrRefCount(mixins[i]->thisPtr); + } TclStackFree(interp, mixins); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- + * * Implementation of the "superclass" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -2170,20 +2241,28 @@ * class of objects. [Bug 9d61624b3d] */ 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 ; iclassPtr, superclasses[i])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "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); } } /* * Install the list of superclasses into the class. Note that this also @@ -2219,10 +2308,16 @@ } oPtr->classPtr->superclasses.list = superclasses; 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); return TCL_OK; } @@ -2229,10 +2324,11 @@ /* * ---------------------------------------------------------------------- * * ClassVarsGet, ClassVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ @@ -2371,10 +2467,11 @@ /* * ---------------------------------------------------------------------- * * ObjectFilterGet, ObjectFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ @@ -2438,10 +2535,11 @@ /* * ---------------------------------------------------------------------- * * ObjectMixinGet, ObjectMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ @@ -2509,13 +2607,23 @@ for (i=0 ; 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); TclStackFree(interp, mixins); return TCL_OK; @@ -2523,10 +2631,11 @@ /* * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ Index: generic/tclOOInt.h ================================================================== --- generic/tclOOInt.h +++ generic/tclOOInt.h @@ -191,13 +191,14 @@ #define OBJECT_DELETED 1 /* Flag to say that an object has been * 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. */ #define FILTER_HANDLING 0x2000 /* Flag set when the object is processing a * filter; when set, filters are *not* @@ -220,14 +221,10 @@ */ 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 * of method call chains. */ LIST_DYNAMIC(struct Class *) subclasses; @@ -493,10 +490,15 @@ MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip, Tcl_Object *objectPtr); +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); MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); @@ -522,14 +524,14 @@ Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); 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); MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, CallContext *contextPtr); @@ -539,23 +541,26 @@ * Include all the private API, generated from tclOO.decls. */ #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 * sets up the declarations needed for the main macro, FOREACH_HASH, which * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that @@ -584,21 +589,10 @@ if (len != 0) { \ memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \ } else { \ (target).list = NULL; \ } \ - } 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 */ /* Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -208,13 +208,12 @@ static int ParseBoolean(Tcl_Obj *objPtr); static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); -#ifndef TCL_WIDE_INT_IS_LONG -static void UpdateStringOfWideInt(Tcl_Obj *objPtr); -static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void UpdateStringOfOldInt(Tcl_Obj *objPtr); #endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void UpdateStringOfBignum(Tcl_Obj *objPtr); static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -240,17 +239,19 @@ * means of functions that can be invoked by generic object code. See also * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager * implementations. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 static const Tcl_ObjType oldBooleanType = { "boolean", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ TclSetBooleanFromAny /* setFromAnyProc */ }; +#endif const Tcl_ObjType tclBooleanType = { "booleanString", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ @@ -262,23 +263,27 @@ NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ SetDoubleFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclIntType = { +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG) "int", /* name */ +#else + "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/ +#endif NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; -#ifndef TCL_WIDE_INT_IS_LONG -const Tcl_ObjType tclWideIntType = { - "wideInt", /* name */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static const Tcl_ObjType oldIntType = { + "int", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfWideInt, /* updateStringProc */ - SetWideIntFromAny /* setFromAnyProc */ + UpdateStringOfOldInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; #endif const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ @@ -342,21 +347,21 @@ Command *cmdPtr; /* A cached Command pointer. */ Namespace *refNsPtr; /* Points to the namespace containing the * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - size_t refNsId; /* refNsPtr's unique namespace id. Used to + unsigned long refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing * namespace was deleted and a new one created * at the same address). */ - size_t refNsCmdEpoch; /* Value of the referencing namespace's + unsigned int refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ - size_t cmdEpoch; /* Value of the command's cmdEpoch when this + unsigned int cmdEpoch; /* Value of the command's cmdEpoch when this * pointer was cached. Before using the cached * pointer, we check if the cmd's epoch was * incremented; if so, the cmd was renamed, * deleted, hidden, or exposed, and so the * pointer is invalid. */ @@ -394,23 +399,25 @@ Tcl_MutexUnlock(&tableMutex); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); - Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); /* For backward compatibility only ... */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + Tcl_RegisterObjType(&tclIntType); +#if !defined(TCL_WIDE_INT_IS_LONG) + Tcl_RegisterObjType(&oldIntType); +#endif Tcl_RegisterObjType(&oldBooleanType); -#ifndef TCL_WIDE_INT_IS_LONG - Tcl_RegisterObjType(&tclWideIntType); #endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; @@ -1760,11 +1767,11 @@ Tcl_NewBooleanObj( register int boolValue) /* Boolean used to initialize new object. */ { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, boolValue!=0); + TclNewIntObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ /* @@ -1808,11 +1815,11 @@ register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = (boolValue != 0); + objPtr->internalRep.wideValue = (boolValue != 0); objPtr->typePtr = &tclIntType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ @@ -1855,11 +1862,11 @@ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetLongObj(objPtr, boolValue!=0); + TclSetIntObj(objPtr, boolValue!=0); } #endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1886,11 +1893,11 @@ register Tcl_Obj *objPtr, /* The object from which to get boolean. */ register int *boolPtr) /* Place to store resulting boolean. */ { do { if (objPtr->typePtr == &tclIntType) { - *boolPtr = (objPtr->internalRep.longValue != 0); + *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } if (objPtr->typePtr == &tclBooleanType) { *boolPtr = (int) objPtr->internalRep.longValue; return TCL_OK; @@ -1914,16 +1921,10 @@ } if (objPtr->typePtr == &tclBignumType) { *boolPtr = 1; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *boolPtr = (objPtr->internalRep.wideValue != 0); - return TCL_OK; - } -#endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } @@ -1958,11 +1959,11 @@ * rep. */ if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { - switch (objPtr->internalRep.longValue) { + switch (objPtr->internalRep.wideValue) { case 0L: case 1L: return TCL_OK; } goto badBoolean; } @@ -1969,16 +1970,10 @@ if (objPtr->typePtr == &tclBignumType) { goto badBoolean; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - goto badBoolean; - } -#endif - if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } } @@ -2111,11 +2106,11 @@ objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = newBool; + objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } /* @@ -2292,26 +2287,20 @@ } *dblPtr = (double) objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *dblPtr = objPtr->internalRep.longValue; + *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { mp_int big; UNPACK_BIGNUM(objPtr, big); *dblPtr = TclBignumToDouble(&big); return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; - return TCL_OK; - } -#endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } /* @@ -2425,11 +2414,11 @@ Tcl_NewIntObj( register int intValue) /* Int used to initialize the new object. */ { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, intValue); + TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* @@ -2458,38 +2447,35 @@ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); } - TclSetLongObj(objPtr, intValue); + TclSetIntObj(objPtr, intValue); } /* *---------------------------------------------------------------------- * * Tcl_GetIntFromObj -- * - * Retrieve the integer value of 'objPtr'. - * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR - * - * An error occurred during conversion or the integral value can not - * be represented as an integer (it might be too large). An error - * message is left in the interpreter's result if 'interp' is not - * NULL. - * - * Effect - * - * 'objPtr' is converted to an integer if necessary if it is not one - * already. The conversion frees any previously-existing internal - * representation. + * Attempt to return an int from the Tcl object "objPtr". If the object + * is not already an int, an attempt will be made to convert it to one. + * + * Integer and long integer objects share the same "integer" type + * implementation. We store all integers as longs and Tcl_GetIntFromObj + * checks whether the current value of the long can be represented by an + * int. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion or if the long integer held by the object can not be + * represented by an int, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already an int, the conversion will free any old + * internal representation. * *---------------------------------------------------------------------- */ int @@ -2539,13 +2525,12 @@ static int SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - long l; - - return TclGetLongFromObj(interp, objPtr, &l); + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); } /* *---------------------------------------------------------------------- * @@ -2569,17 +2554,33 @@ UpdateStringOfInt( register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { char buffer[TCL_INTEGER_SPACE]; register int len; + + len = TclFormatInt(buffer, objPtr->internalRep.wideValue); + + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, (unsigned) len + 1); + objPtr->length = len; +} + +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void +UpdateStringOfOldInt( + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE]; + register int len; len = TclFormatInt(buffer, objPtr->internalRep.longValue); objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } +#endif /* *---------------------------------------------------------------------- * * Tcl_NewLongObj -- @@ -2607,12 +2608,12 @@ * None. * *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewLongObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewLongObj( register long longValue) /* Long integer used to initialize the * new object. */ @@ -2627,11 +2628,11 @@ register long longValue) /* Long integer used to initialize the * new object. */ { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, longValue); + TclNewIntObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* @@ -2664,10 +2665,11 @@ * Allocates memory. * *---------------------------------------------------------------------- */ +#undef Tcl_DbNewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewLongObj( register long longValue, /* Long integer used to initialize the new @@ -2680,11 +2682,11 @@ register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = longValue; + objPtr->internalRep.wideValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ @@ -2718,10 +2720,11 @@ * rep is freed. * *---------------------------------------------------------------------- */ +#undef Tcl_SetLongObj void Tcl_SetLongObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ register long longValue) /* Long integer used to initialize the * object's value. */ @@ -2728,11 +2731,11 @@ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } - TclSetLongObj(objPtr, longValue); + TclSetIntObj(objPtr, longValue); } /* *---------------------------------------------------------------------- * @@ -2759,16 +2762,17 @@ Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr, /* The object from which to get a long. */ register long *longPtr) /* Place to store resulting long. */ { do { +#if (LONG_MAX == LLONG_MAX) if (objPtr->typePtr == &tclIntType) { - *longPtr = objPtr->internalRep.longValue; + *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { +#else + if (objPtr->typePtr == &tclIntType) { /* * We return any integer in the range -ULONG_MAX to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves * existing semantics for conversion of integers on input, but * avoids inadvertent demotion of wide integers to 32-bit ones in @@ -2821,11 +2825,11 @@ *longPtr = (long) value; } return TCL_OK; } } -#ifndef TCL_WIDE_INT_IS_LONG +#if (LONG_MAX != LLONG_MAX) tooLarge: #endif if (interp != NULL) { const char *s = "integer value too large to represent"; Tcl_Obj *msg = Tcl_NewStringObj(s, -1); @@ -2837,53 +2841,10 @@ } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfWideInt -- - * - * Update the string representation for a wide integer object. Note: this - * function does not free an existing old string rep so storage will be - * lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from the - * wideInt-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfWideInt( - register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ -{ - char buffer[TCL_INTEGER_SPACE+2]; - register unsigned len; - register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; - - /* - * Note that sprintf will generate a compiler warning under Mingw claiming - * %I64 is an unknown format specifier. Just ignore this warning. We can't - * use %L as the format specifier since that gets printed as a 32 bit - * value. - */ - - sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); - len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, len + 1); - objPtr->length = len; -} -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- * * Tcl_NewWideIntObj -- @@ -2929,11 +2890,11 @@ * object. */ { register Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* @@ -2981,11 +2942,11 @@ * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } #else /* if not TCL_MEM_DEBUG */ @@ -3030,23 +2991,11 @@ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } - if ((wideValue >= (Tcl_WideInt) LONG_MIN) - && (wideValue <= (Tcl_WideInt) LONG_MAX)) { - TclSetLongObj(objPtr, (long) wideValue); - } else { -#ifndef TCL_WIDE_INT_IS_LONG - TclSetWideIntObj(objPtr, wideValue); -#else - mp_int big; - - TclInitBignumFromWideInt(&big, wideValue); - Tcl_SetBignumObj(objPtr, &big); -#endif - } + TclSetIntObj(objPtr, wideValue); } /* *---------------------------------------------------------------------- * @@ -3074,18 +3023,12 @@ register Tcl_Obj *objPtr, /* Object from which to get a wide int. */ register Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { do { -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } -#endif if (objPtr->typePtr == &tclIntType) { - *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3134,37 +3077,10 @@ } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG - -/* - *---------------------------------------------------------------------- - * - * SetWideIntFromAny -- - * - * Attempts to force the internal representation for a Tcl object to - * tclWideIntType, specifically. - * - * Results: - * The return value is a standard object Tcl result. If an error occurs - * during conversion, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - *---------------------------------------------------------------------- - */ - -static int -SetWideIntFromAny( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Obj *objPtr) /* Pointer to the object to convert */ -{ - Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); -} -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- * * FreeBignum -- @@ -3403,20 +3319,14 @@ } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - TclInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { TclInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } -#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); @@ -3522,40 +3432,15 @@ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) { - unsigned long value = 0, numBytes = sizeof(long); - long scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { - goto tooLargeForLong; - } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { - goto tooLargeForLong; - } - if (bignumValue->sign) { - TclSetLongObj(objPtr, -(long)value); - } else { - TclSetLongObj(objPtr, (long)value); - } - mp_clear(bignumValue); - return; - } - tooLargeForLong: -#ifndef TCL_WIDE_INT_IS_LONG - if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { + <= (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; - unsigned long numBytes = sizeof(Tcl_WideInt); - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *)&scratch; + unsigned long numBytes = sizeof(Tcl_WideUInt); + Tcl_WideUInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { goto tooLargeForWide; } while (numBytes-- > 0) { @@ -3563,19 +3448,18 @@ } if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { goto tooLargeForWide; } if (bignumValue->sign) { - TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); + TclSetIntObj(objPtr, -(Tcl_WideInt)value); } else { - TclSetWideIntObj(objPtr, (Tcl_WideInt)value); + TclSetIntObj(objPtr, (Tcl_WideInt)value); } mp_clear(bignumValue); return; } tooLargeForWide: -#endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); } @@ -3653,21 +3537,14 @@ } *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *typePtr = TCL_NUMBER_LONG; - *clientDataPtr = &objPtr->internalRep.longValue; - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } -#endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int) sizeof(mp_int)); Index: generic/tclPathObj.c ================================================================== --- generic/tclPathObj.c +++ generic/tclPathObj.c @@ -1807,11 +1807,10 @@ /* * We now own a reference on both 'dir' and 'copy' */ (void) TclGetStringFromObj(dir, &cwdLen); - cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); /* Normalize the combined string. */ if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) { /* @@ -1829,16 +1828,16 @@ /* * ... but in most cases where we join a trouble free tail to a * normalized head, we can more efficiently normalize the combined * path by passing over only the unnormalized tail portion. When * this is sufficient, prior developers claim this should be much - * faster. We use 'cwdLen-1' so that we are already pointing at + * faster. We use 'cwdLen' so that we are already pointing at * the dir-separator that we know about. The normalization code * will actually start off directly after that separator. */ - TclFSNormalizeToUniquePath(interp, copy, cwdLen-1); + TclFSNormalizeToUniquePath(interp, copy, cwdLen); } /* Now we need to construct the new path object. */ if (pathType == TCL_PATH_RELATIVE) { Index: generic/tclPkg.c ================================================================== --- generic/tclPkg.c +++ generic/tclPkg.c @@ -416,11 +416,11 @@ void *clientDataPtr) { Interp *iPtr = (Interp *) interp; Package *pkgPtr; PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion; + char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ int availStable, code, satisfies, pass; char *script, *pkgVersionI; Tcl_DString command; @@ -464,10 +464,11 @@ */ bestPtr = NULL; bestStablePtr = NULL; bestVersion = NULL; + bestStableVersion = NULL; for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { @@ -478,63 +479,89 @@ */ continue; } - if (bestPtr != NULL) { - int res = CompareVersions(availVersion, bestVersion, NULL); - - /* - * Note: Use internal reps! - */ - - if (res <= 0) { - /* - * The version of the package sought is not as good as the - * currently selected version. Ignore it. - */ - - ckfree(availVersion); - availVersion = NULL; - continue; - } - } - - /* - * We have found a version which is better than our max. - */ - + /* Check satisfaction of requirements before considering the current version further. */ if (reqc > 0) { - /* Check satisfaction of requirements. */ - satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { ckfree(availVersion); availVersion = NULL; continue; } } - bestPtr = availPtr; - - if (bestVersion != NULL) { - ckfree(bestVersion); - } - bestVersion = availVersion; - - /* - * If this new best version is stable then it also has to be - * better than the max stable version found so far. - */ - - if (availStable) { + if (bestPtr != NULL) { + int res = CompareVersions(availVersion, bestVersion, NULL); + + /* + * Note: Used internal reps in the comparison! + */ + + if (res > 0) { + /* + * The version of the package sought is better than the + * currently selected version. + */ + ckfree(bestVersion); + bestVersion = NULL; + goto newbest; + } + } else { + newbest: + /* We have found a version which is better than our max. */ + + bestPtr = availPtr; + CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); + } + + if (!availStable) { + ckfree(availVersion); + availVersion = NULL; + continue; + } + + if (bestStablePtr != NULL) { + int res = CompareVersions(availVersion, bestStableVersion, NULL); + + /* + * Note: Used internal reps in the comparison! + */ + + if (res > 0) { + /* + * This stable version of the package sought is better + * than the currently selected stable version. + */ + ckfree(bestStableVersion); + bestStableVersion = NULL; + goto newstable; + } + } else { + newstable: + /* We have found a stable version which is better than our max stable. */ bestStablePtr = availPtr; + CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); } - } + + ckfree(availVersion); + availVersion = NULL; + } /* end for */ + + /* + * Clean up memorized internal reps, if any. + */ if (bestVersion != NULL) { ckfree(bestVersion); + bestVersion = NULL; + } + + if (bestStableVersion != NULL) { + ckfree(bestStableVersion); + bestStableVersion = NULL; } /* * Now choose a version among the two best. For 'latest' we simply * take (actually keep) the best. For 'stable' we take the best @@ -919,10 +946,11 @@ pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; } ckfree(availPtr); } ckfree(pkgPtr); } @@ -972,10 +1000,11 @@ return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; } break; } } ckfree(argv3i); @@ -983,11 +1012,11 @@ if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); - availPtr->pkgIndex = 0; + availPtr->pkgIndex = NULL; DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { availPtr->nextPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr; @@ -1355,10 +1384,11 @@ pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; } ckfree(availPtr); } ckfree(pkgPtr); } Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -122,15 +122,14 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; Proc *procPtr; - const char *fullName; - const char *procName, *procArgs, *procBody; + const char *procName; + const char *simpleName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; - Tcl_DString ds; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; } @@ -139,66 +138,43 @@ * Determine the namespace where the procedure should reside. Unless the * command name includes namespace qualifiers, this will be the current * namespace. */ - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); - return TCL_ERROR; - } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\" in non-global namespace with" - " name starting with \":\"", procName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } /* * Create the data structure to represent the procedure. */ - if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3], &procPtr) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, procName); + Tcl_AddErrorInfo(interp, simpleName); Tcl_AddErrorInfo(interp, "\")"); return TCL_ERROR; } - /* - * Now create a command for the procedure. This will initially be in the - * current namespace unless the procedure's name included namespace - * qualifiers. To create the new command in the right namespace, we - * generate a fully qualified name for it. - */ - - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, - TclNRInterpProc, procPtr, TclProcDeleteProc); - Tcl_DStringFree(&ds); + cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, + TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); /* * Now initialize the new procedure's cmdPtr field. This will be used * later when the procedure is called to determine what namespace the * procedure will run in. This will be different than the current @@ -812,19 +788,19 @@ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) && (level >= 0)) { level = curLevel - level; result = 1; } else if (objPtr->typePtr == &levelReferenceType) { - level = (int) objPtr->internalRep.longValue; + level = (int) objPtr->internalRep.wideValue; result = 1; } else { name = TclGetString(objPtr); if (name[0] == '#') { if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { TclFreeIntRep(objPtr); objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.longValue = level; + objPtr->internalRep.wideValue = level; result = 1; } else { result = -1; } } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ @@ -2402,11 +2378,11 @@ * to free. */ { Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; - if (procPtr->refCount-- == 1) { + if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); objPtr->typePtr = NULL; } Index: generic/tclResult.c ================================================================== --- generic/tclResult.c +++ generic/tclResult.c @@ -25,10 +25,13 @@ */ static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); +#ifndef TCL_NO_DEPRECATED +static void SetupAppendBuffer(Interp *iPtr, int newSpace); +#endif /* !TCL_NO_DEPRECATED */ /* * This structure is used to take a snapshot of the interpreter state in * Tcl_SaveInterpState. You can snapshot the state, execute a command, and * then back up to the result or the error that was previously in progress. @@ -242,13 +245,51 @@ * Move the result object into the save state. Note that we don't need to * change its refcount because we're moving it, not adding a new * reference. Put an empty object into the interpreter. */ - *statePtr = iPtr->objResultPtr; + statePtr->objResultPtr = iPtr->objResultPtr; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); + + /* + * Save the string result. + */ + + statePtr->freeProc = iPtr->freeProc; + if (iPtr->result == iPtr->resultSpace) { + /* + * Copy the static string data out of the interp buffer. + */ + + statePtr->result = statePtr->resultSpace; + strcpy(statePtr->result, iPtr->result); + statePtr->appendResult = NULL; + } else if (iPtr->result == iPtr->appendResult) { + /* + * Move the append buffer out of the interp. + */ + + statePtr->appendResult = iPtr->appendResult; + statePtr->appendAvl = iPtr->appendAvl; + statePtr->appendUsed = iPtr->appendUsed; + statePtr->result = statePtr->appendResult; + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; + } else { + /* + * Move the dynamic or static string out of the interpreter. + */ + + statePtr->result = iPtr->result; + statePtr->appendResult = NULL; + } + + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + iPtr->freeProc = 0; } /* *---------------------------------------------------------------------- * @@ -274,17 +315,50 @@ Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ { Interp *iPtr = (Interp *) interp; Tcl_ResetResult(interp); + + /* + * Restore the string result. + */ + + iPtr->freeProc = statePtr->freeProc; + if (statePtr->result == statePtr->resultSpace) { + /* + * Copy the static string data into the interp buffer. + */ + + iPtr->result = iPtr->resultSpace; + strcpy(iPtr->result, statePtr->result); + } else if (statePtr->result == statePtr->appendResult) { + /* + * Move the append buffer back into the interp. + */ + + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + + iPtr->appendResult = statePtr->appendResult; + iPtr->appendAvl = statePtr->appendAvl; + iPtr->appendUsed = statePtr->appendUsed; + iPtr->result = iPtr->appendResult; + } else { + /* + * Move the dynamic or static string back into the interpreter. + */ + + iPtr->result = statePtr->result; + } /* * Restore the object result. */ Tcl_DecrRefCount(iPtr->objResultPtr); - iPtr->objResultPtr = *statePtr; + iPtr->objResultPtr = statePtr->objResultPtr; } /* *---------------------------------------------------------------------- * @@ -306,11 +380,19 @@ #undef Tcl_DiscardResult void Tcl_DiscardResult( Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ { - Tcl_DecrRefCount(*statePtr); + TclDecrRefCount(statePtr->objResultPtr); + + if (statePtr->result == statePtr->appendResult) { + ckfree(statePtr->appendResult); + } else if (statePtr->freeProc == TCL_DYNAMIC) { + ckfree(statePtr->result); + } else if (statePtr->freeProc) { + statePtr->freeProc(statePtr->result); + } } /* *---------------------------------------------------------------------- * @@ -336,19 +418,53 @@ * is set to an empty string. */ Tcl_FreeProc *freeProc) /* Gives information about the string: * TCL_STATIC, TCL_VOLATILE, or the address of * a Tcl_FreeProc such as free. */ { - Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); - if (result == NULL || freeProc == NULL || freeProc == TCL_VOLATILE) { - return; - } - if (freeProc == TCL_DYNAMIC) { - ckfree(result); + Interp *iPtr = (Interp *) interp; + register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; + char *oldResult = iPtr->result; + + if (result == NULL) { + iPtr->resultSpace[0] = 0; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } else if (freeProc == TCL_VOLATILE) { + int length = strlen(result); + + if (length > TCL_RESULT_SIZE) { + iPtr->result = ckalloc(length + 1); + iPtr->freeProc = TCL_DYNAMIC; + } else { + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } + memcpy(iPtr->result, result, (unsigned) length+1); } else { - (*freeProc)(result); + iPtr->result = (char *) result; + iPtr->freeProc = freeProc; + } + + /* + * If the old result was dynamically-allocated, free it up. Do it here, + * rather than at the beginning, in case the new result value was part of + * the old result value. + */ + + if (oldFreeProc != 0) { + if (oldFreeProc == TCL_DYNAMIC) { + ckfree(oldResult); + } else { + oldFreeProc(oldResult); + } } + + /* + * Reset the object result since we just set the string result. + */ + + ResetObjResult(iPtr); } #endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -370,12 +486,24 @@ const char * Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { Interp *iPtr = (Interp *) interp; - +#ifdef TCL_NO_DEPRECATED return Tcl_GetString(iPtr->objResultPtr); +#else + /* + * If the string result is empty, move the object result to the string + * result, then reset the object result. + */ + + if (*(iPtr->result) == 0) { + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + } + return iPtr->result; +#endif } /* *---------------------------------------------------------------------- * @@ -412,10 +540,27 @@ * We wait until the end to release the old object result, in case we are * setting the result to itself. */ TclDecrRefCount(oldObjResult); + +#ifndef TCL_NO_DEPRECATED + /* + * Reset the string result since we just set the result object. + */ + + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +#endif } /* *---------------------------------------------------------------------- * @@ -440,11 +585,38 @@ Tcl_Obj * Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED + Tcl_Obj *objResultPtr; + int length; + /* + * If the string result is non-empty, move the string result to the object + * result, then reset the string result. + */ + + if (iPtr->result[0] != 0) { + ResetObjResult(iPtr); + + objResultPtr = iPtr->objResultPtr; + length = strlen(iPtr->result); + TclInitStringRep(objResultPtr, iPtr->result, length); + + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->result[0] = 0; + } +#endif /* !TCL_NO_DEPRECATED */ return iPtr->objResultPtr; } /* *---------------------------------------------------------------------- @@ -477,10 +649,27 @@ if (Tcl_IsShared(objPtr)) { objPtr = Tcl_DuplicateObj(objPtr); } Tcl_AppendStringsToObjVA(objPtr, argList); Tcl_SetObjResult(interp, objPtr); + + /* + * Strictly we should call Tcl_GetStringResult(interp) here to make sure + * that interp->result is correct according to the old contract, but that + * makes the performance of much code (e.g. in Tk) absolutely awful. So we + * leave it out; code that really wants interp->result can just insert the + * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] + */ + +#ifdef USE_INTERP_RESULT + /* + * Ensure that the interp->result is legal so old Tcl 7.* code still + * works. There's still embarrasingly much of it about... + */ + + (void) Tcl_GetStringResult(interp); +#endif /* USE_INTERP_RESULT */ } /* *---------------------------------------------------------------------- * @@ -542,10 +731,11 @@ * extended. */ const char *element) /* String to convert to list element and add * to result. */ { Interp *iPtr = (Interp *) interp; +#ifdef TCL_NO_DEPRECATED Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); const char *bytes; if (Tcl_IsShared(iPtr->objResultPtr)) { @@ -555,29 +745,157 @@ if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) { Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); } Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); Tcl_DecrRefCount(listPtr); +#else + char *dst; + int size; + int flags; + + /* + * If the string result is empty, move the object result to the string + * result, then reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + + /* + * See how much space is needed, and grow the append buffer if needed to + * accommodate the list element. + */ + + size = Tcl_ScanElement(element, &flags) + 1; + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, size+iPtr->appendUsed); + } + + /* + * Convert the string into a list element and copy it to the buffer that's + * forming, with a space separator if needed. + */ + + dst = iPtr->appendResult + iPtr->appendUsed; + if (TclNeedSpace(iPtr->appendResult, dst)) { + iPtr->appendUsed++; + *dst = ' '; + dst++; + + /* + * If we need a space to separate this element from preceding stuff, + * then this element will not lead a list, and need not have it's + * leading '#' quoted. + */ + + flags |= TCL_DONT_QUOTE_HASH; + } + iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); +#endif /* !TCL_NO_DEPRECATED */ +} + +/* + *---------------------------------------------------------------------- + * + * SetupAppendBuffer -- + * + * This function makes sure that there is an append buffer properly + * initialized, if necessary, from the interpreter's result, and that it + * has at least enough room to accommodate newSpace new bytes of + * information. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +static void +SetupAppendBuffer( + Interp *iPtr, /* Interpreter whose result is being set up. */ + int newSpace) /* Make sure that at least this many bytes of + * new information may be added. */ +{ + int totalSpace; + + /* + * Make the append buffer larger, if that's necessary, then copy the + * result into the append buffer and make the append buffer the official + * Tcl result. + */ + + if (iPtr->result != iPtr->appendResult) { + /* + * If an oversized buffer was used recently, then free it up so we go + * back to a smaller buffer. This avoids tying up memory forever after + * a large operation. + */ + + if (iPtr->appendAvl > 500) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + } + iPtr->appendUsed = strlen(iPtr->result); + } else if (iPtr->result[iPtr->appendUsed] != 0) { + /* + * Most likely someone has modified a result created by + * Tcl_AppendResult et al. so that it has a different size. Just + * recompute the size. + */ + + iPtr->appendUsed = strlen(iPtr->result); + } + + totalSpace = newSpace + iPtr->appendUsed; + if (totalSpace >= iPtr->appendAvl) { + char *new; + + if (totalSpace < 100) { + totalSpace = 200; + } else { + totalSpace *= 2; + } + new = ckalloc(totalSpace); + strcpy(new, iPtr->result); + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + iPtr->appendResult = new; + iPtr->appendAvl = totalSpace; + } else if (iPtr->result != iPtr->appendResult) { + strcpy(iPtr->appendResult, iPtr->result); + } + + Tcl_FreeResult((Tcl_Interp *) iPtr); + iPtr->result = iPtr->appendResult; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * * Tcl_FreeResult -- * * This function frees up the memory associated with an interpreter's - * result, resetting the interpreter's result object. Tcl_FreeResult is - * most commonly used when a function is about to replace one result - * value with another. + * string result. It also resets the interpreter's result object. + * Tcl_FreeResult is most commonly used when a function is about to + * replace one result value with another. * * Results: * None. * * Side effects: - * Frees the memory associated with interp's result but does not change - * any part of the error dictionary (i.e., the errorinfo and errorcode - * remain the same). + * Frees the memory associated with interp's string result and sets + * interp->freeProc to zero, but does not change interp->result or clear + * error state. Resets interp's result object to an unshared empty + * object. * *---------------------------------------------------------------------- */ void @@ -584,10 +902,21 @@ Tcl_FreeResult( register Tcl_Interp *interp)/* Interpreter for which to free result. */ { register Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } + +#endif /* !TCL_NO_DEPRECATED */ ResetObjResult(iPtr); } /* *---------------------------------------------------------------------- @@ -613,10 +942,22 @@ register Tcl_Interp *interp)/* Interpreter for which to clear result. */ { register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); +#ifndef TCL_NO_DEPRECATED + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, TCL_GLOBAL_ONLY); Index: generic/tclScan.c ================================================================== --- generic/tclScan.c +++ generic/tclScan.c @@ -887,11 +887,11 @@ offset = TclUtfToUniChar(string, &sch); i = (int)sch; #if TCL_UTF_MAX == 4 if (!offset) { - offset = Tcl_UtfToUniChar(string, &sch); + offset = TclUtfToUniChar(string, &sch); i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); } #endif string += offset; if (!(flags & SCAN_SUPPRESS)) { @@ -940,11 +940,11 @@ if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { sprintf(buf, "%" TCL_LL_MODIFIER "u", (Tcl_WideUInt)wideValue); Tcl_SetStringObj(objPtr, buf, -1); } else { - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); } } else if (!(flags & SCAN_BIG)) { if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) { if (TclGetString(objPtr)[0] == '-') { value = LONG_MIN; @@ -954,11 +954,11 @@ } if ((flags & SCAN_UNSIGNED) && (value < 0)) { sprintf(buf, "%lu", value); /* INTL: ISO digit */ Tcl_SetStringObj(objPtr, buf, -1); } else { - Tcl_SetLongObj(objPtr, value); + TclSetIntObj(objPtr, value); } } objs[objIndex++] = objPtr; break; Index: generic/tclStrToD.c ================================================================== --- generic/tclStrToD.c +++ generic/tclStrToD.c @@ -481,11 +481,11 @@ int flags) /* Flags governing the parse. */ { enum State { INITIAL, SIGNUM, ZERO, ZERO_X, ZERO_O, ZERO_B, ZERO_D, BINARY, - HEXADECIMAL, OCTAL, DECIMAL, + HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY #ifdef IEEE_FLOATING_POINT , sN, sNA, sNAN, sNANPAREN, sNANHEX, sNANFINISH @@ -526,10 +526,11 @@ * point. */ int status = TCL_OK; /* Status to return to caller. */ char d = 0; /* Last hexadecimal digit scanned; initialized * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ + int explicitOctal = 0; #define ALL_BITS (~(Tcl_WideUInt)0) #define MOST_BITS (ALL_BITS >> 1) /* @@ -657,18 +658,22 @@ } if (flags & TCL_PARSE_BINARY_ONLY) { goto zerob; } if (c == 'o' || c == 'O') { + explicitOctal = 1; state = ZERO_O; break; } if (c == 'd' || c == 'D') { state = ZERO_D; break; } +#ifdef TCL_NO_DEPRECATED goto decimal; +#endif + /* FALLTHROUGH */ case OCTAL: /* * Scanned an optional + or -, followed by a string of octal * digits. Acceptable inputs are more digits, period, or E. If 8 @@ -727,10 +732,62 @@ } numTrailZeros = 0; state = OCTAL; break; } + /* FALLTHROUGH */ + + case BAD_OCTAL: + if (explicitOctal) { + /* + * No forgiveness for bad digits in explicitly octal numbers. + */ + + goto endgame; + } + if (flags & TCL_PARSE_INTEGER_ONLY) { + /* + * No seeking floating point when parsing only integer. + */ + + goto endgame; + } +#ifndef TCL_NO_DEPRECATED + + /* + * Scanned a number with a leading zero that contains an 8, 9, + * radix point or E. This is an invalid octal number, but might + * still be floating point. + */ + + if (c == '0') { + numTrailZeros++; + state = BAD_OCTAL; + break; + } else if (isdigit(UCHAR(c))) { + if (objPtr != NULL) { + significandOverflow = AccumulateDecimalDigit( + (unsigned)(c-'0'), numTrailZeros, + &significandWide, &significandBig, + significandOverflow); + } + if (numSigDigs != 0) { + numSigDigs += (numTrailZeros + 1); + } else { + numSigDigs = 1; + } + numTrailZeros = 0; + state = BAD_OCTAL; + break; + } else if (c == '.') { + state = FRACTION; + break; + } else if (c == 'E' || c == 'e') { + state = EXPONENT_START; + break; + } +#endif goto endgame; /* * Scanned 0x. If state is HEXADECIMAL, scanned at least one * character following the 0x. The only acceptable inputs are @@ -841,11 +898,13 @@ /* * Scanned an optional + or - followed by a string of decimal * digits. */ +#ifdef TCL_NO_DEPRECATED decimal: +#endif acceptState = state; acceptPoint = p; acceptLen = len; if (c == '0') { numTrailZeros++; @@ -1125,10 +1184,11 @@ if (status == TCL_OK && objPtr != NULL) { TclFreeIntRep(objPtr); switch (acceptState) { case SIGNUM: + case BAD_OCTAL: case ZERO_X: case ZERO_O: case ZERO_B: case ZERO_D: case LEADING_RADIX_POINT: @@ -1206,36 +1266,22 @@ mp_mul_2d(&octalSignificandBig, shift, &octalSignificandBig); } } if (!octalSignificandOverflow) { - if (octalSignificandWide > - (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef TCL_WIDE_INT_IS_LONG - if (octalSignificandWide <= (MOST_BITS + signum)) { - objPtr->typePtr = &tclWideIntType; - if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) octalSignificandWide; - } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; - } - break; - } -#endif + if (octalSignificandWide > (MOST_BITS + signum)) { TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.longValue = - - (long) octalSignificandWide; + objPtr->internalRep.wideValue = + - (Tcl_WideInt) octalSignificandWide; } else { - objPtr->internalRep.longValue = - (long) octalSignificandWide; + objPtr->internalRep.wideValue = + (Tcl_WideInt) octalSignificandWide; } } } if (octalSignificandOverflow) { if (signum) { @@ -1253,36 +1299,22 @@ significandOverflow = 1; TclInitBignumFromWideUInt(&significandBig, significandWide); } returnInteger: if (!significandOverflow) { - if (significandWide > - (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef TCL_WIDE_INT_IS_LONG - if (significandWide <= MOST_BITS+signum) { - objPtr->typePtr = &tclWideIntType; - if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) significandWide; - } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; - } - break; - } -#endif + if (significandWide > MOST_BITS+signum) { TclInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.longValue = - - (long) significandWide; + objPtr->internalRep.wideValue = + - (Tcl_WideInt) significandWide; } else { - objPtr->internalRep.longValue = - (long) significandWide; + objPtr->internalRep.wideValue = + (Tcl_WideInt) significandWide; } } } if (significandOverflow) { if (signum) { @@ -1350,10 +1382,13 @@ Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"", expected); Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); Tcl_AppendToObj(msg, "\"", -1); + if (state == BAD_OCTAL) { + Tcl_AppendToObj(msg, " (looks like invalid octal number)", -1); + } Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); } } Index: generic/tclStringObj.c ================================================================== --- generic/tclStringObj.c +++ generic/tclStringObj.c @@ -416,13 +416,18 @@ /* 0 bytes -> 0 chars; 1 byte -> 1 char */ return objPtr->length; } /* - * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the get-length operation. + * Optimize the case where we're really dealing with a bytearray object; + * we don't need to convert to a string to perform the get-length operation. + * + * Starting in Tcl 8.7, we check for a "pure" bytearray, because the + * machinery behind that test is using a proper bytearray ObjType. We + * could also compute length of an improper bytearray without shimmering + * but there's no value in that. We *want* to shimmer an improper bytearray + * because improper bytearrays have worthless internal reps. */ if (TclIsPureByteArray(objPtr)) { int length; @@ -515,11 +520,11 @@ * * Tcl_GetUnicode -- * * 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: * Returns a pointer to the object's internal Unicode string. * @@ -649,10 +654,21 @@ } FillUnicodeRep(objPtr); 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+1numChars) && ((stringPtr->unicode[last+1]&0xFC00) == 0xDC00) + && ((stringPtr->unicode[last]&0xFC00) == 0xD800)) { + ++last; + } +#endif return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1); } /* *---------------------------------------------------------------------- @@ -1867,32 +1883,32 @@ #endif } } else if (ch == 'I') { if ((format[1] == '6') && (format[2] == '4')) { format += (step + 2); - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG useWide = 1; #endif } else if ((format[1] == '3') && (format[2] == '2')) { format += (step + 2); - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } else { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } } else if ((ch == 't') || (ch == 'z')) { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG if (sizeof(size_t) > sizeof(int)) { useWide = 1; } #endif } else if ((ch == 'q') ||(ch == 'j')) { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG useWide = 1; #endif } Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -29,10 +29,11 @@ #undef Tcl_NewByteArrayObj #undef Tcl_NewDoubleObj #undef Tcl_NewIntObj #undef Tcl_NewListObj #undef Tcl_NewLongObj +#undef Tcl_DbNewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry @@ -40,40 +41,53 @@ #undef Tcl_Panic #undef Tcl_FindExecutable #undef TclpGetPid #undef TclSockMinimumBuffers #undef Tcl_SetIntObj +#undef Tcl_SetLongObj #undef TclpInetNtoa #undef TclWinGetServByName #undef TclWinGetSockOpt #undef TclWinSetSockOpt #undef TclWinNToHS /* See bug 510001: TclSockMinimumBuffers needs plat imp */ -#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) +#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 # define TclSockMinimumBuffersOld 0 #else #define TclSockMinimumBuffersOld sockMinimumBuffersOld static int TclSockMinimumBuffersOld(int sock, int size) { return TclSockMinimumBuffers(INT2PTR(sock), size); } #endif -#if defined(TCL_NO_DEPRECATED) +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 # define TclSetStartupScriptPath 0 # define TclGetStartupScriptPath 0 # define TclSetStartupScriptFileName 0 # define TclGetStartupScriptFileName 0 +# define TclPrecTraceProc 0 # define TclpInetNtoa 0 # define TclWinGetServByName 0 # define TclWinGetSockOpt 0 # 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) { Tcl_SetStartupScript(path, NULL); @@ -96,17 +110,32 @@ if (path == NULL) { return NULL; } return Tcl_GetString(path); } - #if defined(_WIN32) || defined(__CYGWIN__) #undef TclWinNToHS +#undef TclWinGetPlatformId +#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); } +#define TclWinGetPlatformId winGetPlatformId +static int +TclWinGetPlatformId(void) +{ + return 2; /* VER_PLATFORM_WIN32_NT */; +} +#define TclWinResetInterfaces doNothing +#define TclWinSetInterfaces (void (*) (int)) doNothing #endif # define TclBNInitBignumFromWideUInt TclInitBignumFromWideUInt # define TclBNInitBignumFromWideInt TclInitBignumFromWideInt # define TclBNInitBignumFromLong TclInitBignumFromLong #endif /* TCL_NO_DEPRECATED */ @@ -117,41 +146,35 @@ # define TclUnixOpenTemporaryFile 0 # define TclpReaddir 0 # 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 - -static Tcl_Encoding winTCharEncoding; static int TclpIsAtty(int fd) { return isatty(fd); } -#define TclWinGetPlatformId winGetPlatformId -static int -TclWinGetPlatformId() -{ - /* Don't bother to determine the real platform on cygwin, - * because VER_PLATFORM_WIN32_NT is the only supported platform */ - return 2; /* VER_PLATFORM_WIN32_NT */; -} - void *TclWinGetTclInstance() { void *hInstance = NULL; GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, - (const char *)&winTCharEncoding, &hInstance); + (const char *)&TclpIsAtty, &hInstance); return hInstance; } -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TclWinSetSockOpt winSetSockOpt static int TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen) { @@ -192,40 +215,50 @@ 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 (!winTCharEncoding) { - winTCharEncoding = Tcl_GetEncoding(0, "unicode"); - } - return Tcl_UtfToExternalDString(winTCharEncoding, - string, len, dsPtr); + WCHAR *wp; + int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0); + + Tcl_DStringInit(dsPtr); + Tcl_DStringSetLength(dsPtr, 2*size+2); + wp = (WCHAR *)Tcl_DStringValue(dsPtr); + MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1); + if (len == -1) --size; /* account for 0-byte at string end */ + Tcl_DStringSetLength(dsPtr, 2*size); + wp[size] = 0; + return (char *)wp; } char * Tcl_WinTCharToUtf( const char *string, int len, Tcl_DString *dsPtr) { - if (!winTCharEncoding) { - winTCharEncoding = Tcl_GetEncoding(0, "unicode"); + char *p; + int size; + + if (len > 0) { + len /= 2; } - return Tcl_ExternalToUtfDString(winTCharEncoding, - string, len, dsPtr); + size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL); + Tcl_DStringInit(dsPtr); + Tcl_DStringSetLength(dsPtr, size+1); + p = (char *)Tcl_DStringValue(dsPtr); + WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); + if (len == -1) --size; /* account for 0-byte at string end */ + Tcl_DStringSetLength(dsPtr, size); + p[size] = 0; + return p; } #if defined(TCL_WIDE_INT_IS_LONG) /* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore * we have to make sure that all stub entries on Cygwin64 follow the Win64 @@ -242,11 +275,11 @@ register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = (long) intValue; + objPtr->internalRep.wideValue = (long) intValue; objPtr->typePtr = &tclIntType; return objPtr; #else return Tcl_NewIntObj(intValue); #endif @@ -309,11 +342,11 @@ #endif /* TCL_WIDE_INT_IS_LONG */ #endif /* __CYGWIN__ */ -#ifdef TCL_NO_DEPRECATED +#if defined(TCL_NO_DEPRECATED) # define Tcl_SeekOld 0 # define Tcl_TellOld 0 # undef Tcl_SetBooleanObj # define Tcl_SetBooleanObj 0 # undef Tcl_PkgPresent @@ -364,10 +397,30 @@ # undef Tcl_GlobalEvalObj # define Tcl_GlobalEvalObj 0 # define TclBackgroundException 0 # undef TclpReaddir # define TclpReaddir 0 +# define TclSetStartupScript 0 +# define TclGetStartupScript 0 +# define TclCreateNamespace 0 +# define TclDeleteNamespace 0 +# define TclAppendExportList 0 +# define TclExport 0 +# define TclImport 0 +# define TclForgetImport 0 +# define TclGetCurrentNamespace_ 0 +# define TclGetGlobalNamespace_ 0 +# define TclFindNamespace 0 +# define TclFindCommand 0 +# define TclGetCommandFromObj 0 +# define TclGetCommandFullName 0 +# define TclCopyChannelOld 0 +# define Tcl_AppendResultVA 0 +# define Tcl_AppendStringsToObjVA 0 +# define Tcl_SetErrorCodeVA 0 +# define Tcl_PanicVA 0 +# define Tcl_VarEvalVA 0 # undef TclpGetDate # define TclpGetDate 0 # undef TclpLocaltime # define TclpLocaltime 0 # undef TclpGmtime @@ -376,10 +429,24 @@ # define TclpGmtime_unix 0 #else /* TCL_NO_DEPRECATED */ # define Tcl_SeekOld seekOld # define Tcl_TellOld tellOld # define TclBackgroundException Tcl_BackgroundException +# define TclSetStartupScript Tcl_SetStartupScript +# define TclGetStartupScript Tcl_GetStartupScript +# define TclCreateNamespace Tcl_CreateNamespace +# define TclDeleteNamespace Tcl_DeleteNamespace +# define TclAppendExportList Tcl_AppendExportList +# define TclExport Tcl_Export +# define TclImport Tcl_Import +# define TclForgetImport Tcl_ForgetImport +# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace +# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace +# define TclFindNamespace Tcl_FindNamespace +# define TclFindCommand Tcl_FindCommand +# define TclGetCommandFromObj Tcl_GetCommandFromObj +# define TclGetCommandFullName Tcl_GetCommandFullName # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime static int seekOld( @@ -528,26 +595,26 @@ 0, /* 107 */ TclTeardownNamespace, /* 108 */ TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - Tcl_AppendExportList, /* 112 */ - Tcl_CreateNamespace, /* 113 */ - Tcl_DeleteNamespace, /* 114 */ - Tcl_Export, /* 115 */ - Tcl_FindCommand, /* 116 */ - Tcl_FindNamespace, /* 117 */ + TclAppendExportList, /* 112 */ + TclCreateNamespace, /* 113 */ + TclDeleteNamespace, /* 114 */ + TclExport, /* 115 */ + TclFindCommand, /* 116 */ + TclFindNamespace, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - Tcl_ForgetImport, /* 121 */ - Tcl_GetCommandFromObj, /* 122 */ - Tcl_GetCommandFullName, /* 123 */ - Tcl_GetCurrentNamespace, /* 124 */ - Tcl_GetGlobalNamespace, /* 125 */ + TclForgetImport, /* 121 */ + TclGetCommandFromObj, /* 122 */ + TclGetCommandFullName, /* 123 */ + TclGetCurrentNamespace_, /* 124 */ + TclGetGlobalNamespace_, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - Tcl_Import, /* 127 */ + TclImport, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ Tcl_SetNamespaceResolvers, /* 131 */ TclpHasSockets, /* 132 */ @@ -594,12 +661,12 @@ TclUniCharMatch, /* 173 */ 0, /* 174 */ TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - Tcl_SetStartupScript, /* 178 */ - Tcl_GetStartupScript, /* 179 */ + TclSetStartupScript, /* 178 */ + TclGetStartupScript, /* 179 */ 0, /* 180 */ 0, /* 181 */ TclpLocaltime, /* 182 */ TclpGmtime, /* 183 */ 0, /* 184 */ Index: generic/tclStubLib.c ================================================================== --- generic/tclStubLib.c +++ generic/tclStubLib.c @@ -64,12 +64,12 @@ * prevents apps from being able to load/unload Tcl dynamically multiple * times. [Bug 615304] */ if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { - iPtr->legacyResult = "interpreter uses an incompatible stubs mechanism"; - iPtr->legacyFreeProc = 0; /* TCL_STATIC */ + iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; + iPtr->freeProc = 0; return NULL; } actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); if (actualVersion == NULL) { Index: generic/tclTest.c ================================================================== --- generic/tclTest.c +++ generic/tclTest.c @@ -303,18 +303,10 @@ static int TestlinkCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); 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, Tcl_Interp *interp, int argc, const char **argv); static int TestexitmainloopCmd(ClientData dummy, @@ -421,10 +413,16 @@ static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr); static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; static int TestNumUtfCharsCmd(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestFindFirstCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestFindLastCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestHashSystemHashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -547,14 +545,10 @@ 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; static const char *const specialOptions[] = { "-appinitprocerror", "-appinitprocdeleteinterp", @@ -690,23 +684,23 @@ NULL, NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", TestsetobjerrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testnumutfchars", TestNumUtfCharsCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testfindfirst", + TestFindFirstCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testfindlast", + TestFindLastCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, NULL, NULL); Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, NULL, NULL); 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, NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, @@ -713,17 +707,10 @@ NULL, NULL); #if defined(HAVE_CPUID) || defined(_WIN32) 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, NULL, NULL); Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, @@ -3345,150 +3332,10 @@ } /* *---------------------------------------------------------------------- * - * 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 * up any data left over from running the testsetassocdata command. * @@ -5226,10 +5073,11 @@ ClientData dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { + Interp* iPtr = (Interp*) interp; int discard, result, index; Tcl_SavedResult state; Tcl_Obj *objPtr; static const char *const optionStrings[] = { "append", "dynamic", "free", "object", "small", NULL @@ -5293,13 +5141,16 @@ Tcl_RestoreResult(interp, &state); result = TCL_OK; } switch ((enum options) index) { - case RESULT_DYNAMIC: - Tcl_AppendElement(interp, freeCount ? "freed" : "leak"); + case RESULT_DYNAMIC: { + int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount; + + Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak"); break; + } case RESULT_OBJECT: Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr ? "same" : "different"); break; default: @@ -6878,10 +6729,54 @@ len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); } return TCL_OK; } + +/* + * Used to check correct operation of Tcl_UtfFindFirst + */ + +static int +TestFindFirstCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc > 1) { + int len = -1; + + if (objc > 2) { + (void) Tcl_GetIntFromObj(interp, objv[2], &len); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1)); + } + return TCL_OK; +} + +/* + * Used to check correct operation of Tcl_UtfFindLast + */ + +static int +TestFindLastCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc > 1) { + int len = -1; + + if (objc > 2) { + (void) Tcl_GetIntFromObj(interp, objv[2], &len); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1)); + } + return TCL_OK; +} #if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- * Index: generic/tclTestObj.c ================================================================== --- generic/tclTestObj.c +++ generic/tclTestObj.c @@ -1086,10 +1086,13 @@ } if (objv[2]->typePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { typeName = objv[2]->typePtr->name; +#ifndef TCL_WIDE_INT_IS_LONG + if (!strcmp(typeName, "wideInt")) typeName = "int"; +#endif Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -1113,10 +1116,15 @@ if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "int", -1); +#endif } else { Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); } } else if (strcmp(subCmd, "types") == 0) { Index: generic/tclTimer.c ================================================================== --- generic/tclTimer.c +++ generic/tclTimer.c @@ -817,13 +817,10 @@ /* * First lets see if the command was passed a number as the first argument. */ if (objv[1]->typePtr == &tclIntType -#ifndef TCL_WIDE_INT_IS_LONG - || objv[1]->typePtr == &tclWideIntType -#endif || objv[1]->typePtr == &tclBignumType || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK)) { index = -1; if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { @@ -1043,41 +1040,31 @@ } } if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif - if (diff > TCL_TIME_MAXIMUM_SLICE) { - diff = TCL_TIME_MAXIMUM_SLICE; - } - if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { - diff = 1; - } - if (diff > 0) { - Tcl_Sleep((long) diff); - if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { - break; - } - } else { - break; - } - } else { - diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif - if (diff > TCL_TIME_MAXIMUM_SLICE) { - diff = TCL_TIME_MAXIMUM_SLICE; - } - if (diff > 0) { - Tcl_Sleep((long) diff); + if (diff > TCL_TIME_MAXIMUM_SLICE) { + diff = TCL_TIME_MAXIMUM_SLICE; + } + if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { + diff = 1; + } + if (diff > 0) { + Tcl_Sleep((int) diff); + if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { + break; + } + } else { + break; + } + } else { + diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); + if (diff > TCL_TIME_MAXIMUM_SLICE) { + diff = TCL_TIME_MAXIMUM_SLICE; + } + if (diff > 0) { + Tcl_Sleep((int) diff); } if (Tcl_AsyncReady()) { if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { return TCL_ERROR; } @@ -1087,11 +1074,11 @@ } if (Tcl_LimitCheck(interp) != TCL_OK) { return TCL_ERROR; } } - Tcl_GetTime(&now); + Tcl_GetTime(&now); } while (TCL_TIME_BEFORE(now, endTime)); return TCL_OK; } /* Index: generic/tclUtf.c ================================================================== --- generic/tclUtf.c +++ generic/tclUtf.c @@ -66,15 +66,11 @@ 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, 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, 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 }; /* *--------------------------------------------------------------------------- @@ -92,11 +88,11 @@ *--------------------------------------------------------------------------- */ int TclUtfCount( - int ch) /* The Tcl_UniChar whose size is returned. */ + int ch) /* The Unicode character whose size is returned. */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { return 1; } if (ch <= 0x7FF) { @@ -326,17 +322,26 @@ /* * A three-byte-character lead-byte not followed by two trail-bytes * 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) | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)) - 0x10000; surrogate = (Tcl_UniChar) (0xD800 + (byte >> 10)); @@ -363,11 +368,10 @@ /* * A four-byte-character lead-byte not followed by two trail-bytes * represents itself. */ } -#endif *chPtr = (Tcl_UniChar) byte; return 1; } @@ -396,11 +400,11 @@ * strlen(). */ Tcl_DString *dsPtr) /* Unicode representation of string is * appended to this previously initialized * DString. */ { - Tcl_UniChar ch, *w, *wString; + Tcl_UniChar ch = 0, *w, *wString; const char *p, *end; int oldLength; if (length < 0) { length = strlen(src); @@ -497,17 +501,17 @@ src += TclUtfToUniChar(src, &ch); i++; } 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++; } if (src < endPtr) { @@ -520,17 +524,17 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfFindFirst -- * - * Returns a pointer to the first occurance of the given Tcl_UniChar in - * the NULL-terminated UTF-8 string. The NULL terminator is considered + * Returns a pointer to the first occurance of the given Unicode character + * in the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, the - * return value is NULL. + * As above. If the Unicode character does not exist in the given string, + * the return value is NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- @@ -537,18 +541,25 @@ */ const char * Tcl_UtfFindFirst( const char *src, /* The UTF-8 string to be searched. */ - int ch) /* The Tcl_UniChar to search for. */ + int ch) /* The Unicode character to search for. */ { - int len; + int len, fullchar; Tcl_UniChar find = 0; while (1) { len = TclUtfToUniChar(src, &find); - if (find == ch) { + fullchar = find; +#if TCL_UTF_MAX == 4 + if (!len) { + len += TclUtfToUniChar(src, &find); + fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; + } +#endif + if (fullchar == ch) { return src; } if (*src == '\0') { return NULL; } @@ -559,16 +570,16 @@ /* *--------------------------------------------------------------------------- * * Tcl_UtfFindLast -- * - * Returns a pointer to the last occurance of the given Tcl_UniChar in - * the NULL-terminated UTF-8 string. The NULL terminator is considered + * Returns a pointer to the last occurance of the given Unicode character + * in the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, the + * As above. If the Unicode character does not exist in the given string, the * return value is NULL. * * Side effects: * None. * @@ -576,20 +587,27 @@ */ const char * Tcl_UtfFindLast( const char *src, /* The UTF-8 string to be searched. */ - int ch) /* The Tcl_UniChar to search for. */ + int ch) /* The Unicode character to search for. */ { - int len; + int len, fullchar; Tcl_UniChar find = 0; const char *last; last = NULL; while (1) { len = TclUtfToUniChar(src, &find); - if (find == ch) { + fullchar = find; +#if TCL_UTF_MAX == 4 + if (!len) { + len += TclUtfToUniChar(src, &find); + fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; + } +#endif + if (fullchar == ch) { last = src; } if (*src == '\0') { break; } @@ -661,11 +679,11 @@ { const char *look; 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; } break; @@ -685,11 +703,11 @@ /* *--------------------------------------------------------------------------- * * Tcl_UniCharAtIndex -- * - * Returns the Unicode character represented at the specified character + * Returns the Tcl_UniChar represented at the specified character * (not byte) position in the UTF-8 string. * * Results: * As above. * @@ -704,12 +722,11 @@ register const char *src, /* The UTF-8 string to dereference. */ register int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; - while (index >= 0) { - index--; + while (index-- >= 0) { src += TclUtfToUniChar(src, &ch); } return ch; } @@ -735,12 +752,11 @@ register const char *src, /* The UTF-8 string. */ register int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; - while (index > 0) { - index--; + while (index-- > 0) { src += TclUtfToUniChar(src, &ch); } return src; } @@ -1051,10 +1067,20 @@ */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { +#if TCL_UTF_MAX == 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif return (ch1 - ch2); } } return 0; } @@ -1082,33 +1108,90 @@ const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ unsigned long numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; + while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. * This should be called only when both strings are of * at least n chars long (no need for \0 check) */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { +#if TCL_UTF_MAX == 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return (ch1 - ch2); } } } return 0; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_UtfCmp -- + * + * Compare UTF chars of string cs to string ct case sensitively. + * Replacement for strcmp in Tcl core, in places where UTF-8 should + * be handled. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUtfCmp( + const char *cs, /* UTF string to compare to ct. */ + const char *ct) /* UTF string cs is compared to. */ +{ + Tcl_UniChar ch1 = 0, ch2 = 0; + + while (*cs && *ct) { + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { +#if TCL_UTF_MAX == 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif + return ch1 - ch2; + } + } + return UCHAR(*cs) - UCHAR(*ct); +} + /* *---------------------------------------------------------------------- * - * Tcl_UtfNcasecmp -- + * TclUtfCasecmp -- * * Compare UTF chars of string cs to string ct case insensitively. * Replacement for strcasecmp in Tcl core, in places where UTF-8 should * be handled. * @@ -1124,16 +1207,26 @@ int TclUtfCasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct) /* UTF string cs is compared to. */ { - while (*cs && *ct) { - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; + while (*cs && *ct) { cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { +#if TCL_UTF_MAX == 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return ch1 - ch2; } Index: generic/tclUtil.c ================================================================== --- generic/tclUtil.c +++ generic/tclUtil.c @@ -972,11 +972,11 @@ const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { - int flags = CONVERT_ANY; + char flags = CONVERT_ANY; int numBytes = TclScanElement(src, length, &flags); *flagPtr = flags; return numBytes; } @@ -1013,11 +1013,11 @@ int TclScanElement( const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ - int *flagPtr) /* Where to store information to guide + char *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { const char *p = src; int nestingLevel = 0; /* Brace nesting count */ int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something @@ -1545,15 +1545,14 @@ char * Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; int i, bytesNeeded = 0; char *result, *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * Handle empty list case first, so logic of the general case can be * simpler. */ @@ -1568,26 +1567,12 @@ * Pass 1: estimate space, gather flags. */ if (argc <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (argc > maxFlags) { - /* - * We cannot allocate a large enough flag array to format this list in - * one pass. We could imagine converting this routine to a multi-pass - * implementation, but for sizeof(int) == 4, the limit is a max of - * 2^30 list elements and since each element is at least one byte - * formatted, and requires one byte space between it and the next one, - * that a minimum space requirement of 2^31 bytes, which is already - * INT_MAX. If we tried to format a list of > maxFlags elements, we're - * just going to overflow the size limits on the formatted string - * anyway, so just issue that same panic early. - */ - - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(argc * sizeof(int)); + flagPtr = ckalloc(argc); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); if (bytesNeeded < 0) { @@ -1617,10 +1602,11 @@ ckfree(flagPtr); } return result; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * * Tcl_Backslash -- * @@ -1650,10 +1636,11 @@ Tcl_UtfBackslash(src, readPtr, buf); TclUtfToUniChar(buf, &ch); return (char) ch; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * * TclTrimRight -- @@ -1678,10 +1665,11 @@ const char *trim, /* String of trim characters... */ int numTrim) /* ...and its length in bytes */ { const char *p = bytes + numBytes; int pInc; + Tcl_UniChar ch1 = 0, ch2 = 0; if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { Tcl_Panic("TclTrimRight works only on null-terminated strings"); } @@ -1696,11 +1684,10 @@ /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; const char *q = trim; int bytesLeft = numTrim; p = Tcl_UtfPrev(p, bytes); pInc = TclUtfToUniChar(p, &ch1); @@ -1708,11 +1695,10 @@ /* * Inner loop: scan trim string for match to current character. */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } @@ -1758,10 +1744,11 @@ int numBytes, /* ...and its length in bytes */ const char *trim, /* String of trim characters... */ int numTrim) /* ...and its length in bytes */ { const char *p = bytes; + Tcl_UniChar ch1 = 0, ch2 = 0; if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { Tcl_Panic("TclTrimLeft works only on null-terminated strings"); } @@ -1776,21 +1763,19 @@ /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; /* * Inner loop: scan trim string for match to current character. */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } @@ -2120,11 +2105,11 @@ * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { int p, charLen; const char *pstart = pattern; - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; while (1) { p = *pattern; /* @@ -2230,11 +2215,11 @@ * list of characters that are acceptable, or by a range (two * characters separated by "-"). */ if (p == '[') { - Tcl_UniChar startChar, endChar; + Tcl_UniChar startChar = 0, endChar = 0; pattern++; if (UCHAR(*str) < 0x80) { ch1 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*str)) : UCHAR(*str)); @@ -2715,11 +2700,11 @@ const char *element) /* String to append. Must be * null-terminated. */ { char *dst = dsPtr->string + dsPtr->length; int needSpace = TclNeedSpace(dsPtr->string, dst); - int flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; + char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; int newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags); /* * Allocate a larger buffer for the string if the current one isn't large @@ -2921,16 +2906,90 @@ Tcl_DStringGetResult( Tcl_Interp *interp, /* Interpreter whose result is to be reset. */ Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { - int length; - char *bytes = TclGetStringFromObj(Tcl_GetObjResult(interp), &length); +#ifdef TCL_NO_DEPRECATED + Tcl_Obj *obj = Tcl_GetObjResult(interp); + const char *bytes = TclGetString(obj); Tcl_DStringFree(dsPtr); - Tcl_DStringAppend(dsPtr, bytes, length); + Tcl_DStringAppend(dsPtr, bytes, obj->length); Tcl_ResetResult(interp); +#else + Interp *iPtr = (Interp *) interp; + + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + + /* + * Do more efficient transfer when we know the result is a Tcl_Obj. When + * there's no string result, we only have to deal with two cases: + * + * 1. When the string rep is the empty string, when we don't copy but + * instead use the staticSpace in the DString to hold an empty string. + + * 2. When the string rep is not there or there's a real string rep, when + * we use Tcl_GetString to fetch (or generate) the string rep - which + * we know to have been allocated with ckalloc() - and use it to + * populate the DString space. Then, we free the internal rep. and set + * the object's string representation back to the canonical empty + * string. + */ + + if (!iPtr->result[0] && iPtr->objResultPtr + && !Tcl_IsShared(iPtr->objResultPtr)) { + if (iPtr->objResultPtr->bytes == &tclEmptyString) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->string[0] = 0; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = TclGetString(iPtr->objResultPtr); + dsPtr->length = iPtr->objResultPtr->length; + dsPtr->spaceAvl = dsPtr->length + 1; + TclFreeIntRep(iPtr->objResultPtr); + iPtr->objResultPtr->bytes = &tclEmptyString; + iPtr->objResultPtr->length = 0; + } + return; + } + + /* + * If the string result is empty, move the object result to the string + * result, then reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + + dsPtr->length = strlen(iPtr->result); + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + dsPtr->string = iPtr->result; + dsPtr->spaceAvl = dsPtr->length+1; + } else { + dsPtr->string = ckalloc(dsPtr->length+1); + memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); + iPtr->freeProc(iPtr->result); + } + dsPtr->spaceAvl = dsPtr->length+1; + iPtr->freeProc = NULL; + } else { + if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = ckalloc(dsPtr->length+1); + dsPtr->spaceAvl = dsPtr->length + 1; + } + memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); + } + + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ } /* *---------------------------------------------------------------------- * @@ -3239,10 +3298,11 @@ * string that's used by Tcl_PrintDouble. * *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ char * TclPrecTraceProc( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter containing variable. */ @@ -3296,10 +3356,11 @@ return (char *) "improper value for precision"; } *precisionPtr = prec; return NULL; } +#endif /* !TCL_NO_DEPRECATED)*/ /* *---------------------------------------------------------------------- * * TclNeedSpace -- @@ -3413,13 +3474,13 @@ int TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ - long n) /* The integer to format. */ + Tcl_WideInt n) /* The integer to format. */ { - long intVal; + Tcl_WideInt intVal; int i; int numFormatted, j; const char *digits = "0123456789"; /* @@ -3438,11 +3499,11 @@ * same value. */ intVal = -n; /* [Bug 3390638] Workaround for*/ if (n == -n || intVal == n) { /* broken compiler optimizers. */ - return sprintf(buffer, "%ld", n); + return sprintf(buffer, "%" TCL_LL_MODIFIER "d", n); } /* * Generate the characters of the result backwards in the buffer. */ @@ -3477,31 +3538,26 @@ /* *---------------------------------------------------------------------- * * TclGetIntForIndex -- * - * Provides an integer corresponding to the list index held in a Tcl - * object. The string value 'objPtr' is expected have the format - * integer([+-]integer)? or end([+-]integer)?. - * - * Value - * TCL_OK - * - * The index is stored at the address given by by 'indexPtr'. If - * 'objPtr' has the value "end", the value stored is 'endValue'. - * - * TCL_ERROR - * - * The value of 'objPtr' does not have one of the expected formats. If - * 'interp' is non-NULL, an error message is left in the interpreter's - * result object. - * - * Effect - * - * The object referenced by 'objPtr' is converted, as needed, to an - * integer, wide integer, or end-based-index object. - * + * This function returns an integer corresponding to the list index held + * in a Tcl object. The Tcl object's value is expected to be in the + * format integer([+-]integer)? or the format end([+-]integer)?. + * + * Results: + * The return value is normally TCL_OK, which means that the index was + * successfully stored into the location referenced by "indexPtr". If the + * Tcl object referenced by "objPtr" has the value "end", the value + * stored is "endValue". If "objPtr"s values is not of one of the + * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, + * an error message is left in the interpreter's result object. + * + * Side effects: + * The object referenced by "objPtr" might be converted to an integer, + * wide integer, or end-based-index object. + * *---------------------------------------------------------------------- */ int TclGetIntForIndex( @@ -3527,11 +3583,11 @@ /* * If the object is already an offset from the end of the list, or can * be converted to one, use it. */ - *indexPtr = endValue + objPtr->internalRep.longValue; + *indexPtr = endValue + objPtr->internalRep.wideValue; return TCL_OK; } bytes = TclGetString(objPtr); length = objPtr->length; @@ -3584,10 +3640,11 @@ "bad index \"%s\": must be integer?[+-]integer? or" " end?[+-]integer?", bytes)); if (!strncmp(bytes, "end-", 4)) { bytes += 4; } + TclCheckBadOctal(interp, bytes); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; } @@ -3618,13 +3675,13 @@ { char buffer[TCL_INTEGER_SPACE + 5]; register int len = 3; memcpy(buffer, "end", 4); - if (objPtr->internalRep.longValue != 0) { + if (objPtr->internalRep.wideValue != 0) { buffer[len++] = '-'; - len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + len += TclFormatInt(buffer+len, -(objPtr->internalRep.wideValue)); } objPtr->bytes = ckalloc((unsigned) len+1); memcpy(objPtr->bytes, buffer, (unsigned) len+1); objPtr->length = len; } @@ -3650,11 +3707,11 @@ static int SetEndOffsetFromAny( Tcl_Interp *interp, /* Tcl interpreter or NULL */ Tcl_Obj *objPtr) /* Pointer to the object to parse */ { - int offset; /* Offset in the "end-offset" expression */ + Tcl_WideInt offset; /* Offset in the "end-offset" expression */ register const char *bytes; /* String rep of the object */ int length; /* Length of the object's string rep */ /* * If it's already the right type, we're fine. @@ -3686,19 +3743,24 @@ if (length <= 3) { offset = 0; } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* * This is our limited string expression evaluator. Pass everything - * after "end-" to Tcl_GetInt, then reverse for offset. + * after "end-" to TclParseNumber. */ if (TclIsSpaceProc(bytes[4])) { goto badIndexFormat; } - if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { + if (TclParseNumber(NULL, objPtr, NULL, bytes+4, length-4, NULL, + TCL_PARSE_INTEGER_ONLY) != TCL_OK) { return TCL_ERROR; } + if (objPtr->typePtr != &tclIntType) { + goto badIndexFormat; + } + offset = objPtr->internalRep.wideValue; if (bytes[3] == '-') { offset = -offset; } } else { /* @@ -3718,15 +3780,82 @@ * The conversion succeeded. Free the old internal rep and set the new * one. */ TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = offset; + objPtr->internalRep.wideValue = offset; objPtr->typePtr = &tclEndOffsetType; return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TclCheckBadOctal -- + * + * This function checks for a bad octal value and appends a meaningful + * error to the interp's result. + * + * Results: + * 1 if the argument was a bad octal, else 0. + * + * Side effects: + * The interpreter's result is modified. + * + *---------------------------------------------------------------------- + */ + +int +TclCheckBadOctal( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + const char *value) /* String to check. */ +{ + register const char *p = value; + + /* + * A frequent mistake is invalid octal values due to an unwanted leading + * zero. Try to generate a meaningful error message. + */ + + while (TclIsSpaceProc(*p)) { + p++; + } + if (*p == '+' || *p == '-') { + p++; + } + if (*p == '0') { + if ((p[1] == 'o') || p[1] == 'O') { + p += 2; + } + while (isdigit(UCHAR(*p))) { /* INTL: digit. */ + p++; + } + while (TclIsSpaceProc(*p)) { + p++; + } + if (*p == '\0') { + /* + * Reached end of string. + */ + + if (interp != NULL) { + /* + * Don't reset the result here because we want this result to + * be added to an existing error message as extra info. + */ + + Tcl_AppendToObj(Tcl_GetObjResult(interp), + " (looks like invalid octal number)", -1); + } + return 1; + } + } + return 0; +} /* *---------------------------------------------------------------------- * * ClearHash -- @@ -3888,11 +4017,11 @@ */ Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } /* @@ -3914,11 +4043,11 @@ ProcessGlobalValue *pgvPtr) { Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - size_t epoch = pgvPtr->epoch; + unsigned int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); if (pgvPtr->encoding != current) { @@ -3948,11 +4077,11 @@ } else { Tcl_FreeEncoding(current); } } cacheMap = GetThreadHash(&pgvPtr->key); - hPtr = Tcl_FindHashEntry(cacheMap, (void *) (epoch)); + hPtr = Tcl_FindHashEntry(cacheMap, (void *)(size_t)epoch); if (NULL == hPtr) { int dummy; /* * No cache for the current epoch - must be a new one. @@ -3981,11 +4110,11 @@ * Store a copy of the shared value in our epoch-indexed cache. */ value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, - (void *)(pgvPtr->epoch), &dummy); + (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); } return Tcl_GetHashValue(hPtr); Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -814,12 +814,16 @@ if (lookGlobal) { *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { - flags = (flags | TCL_NAMESPACE_ONLY); - *indexPtr = -2; + if (flags & TCL_AVOID_RESOLVERS) { + flags = (flags | TCL_NAMESPACE_ONLY); + } + if (flags & TCL_NAMESPACE_ONLY) { + *indexPtr = -2; + } } /* * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, or * otherwise generate our own error! @@ -5703,14 +5707,10 @@ /* * Find the namespace(s) that contain the variable. */ - if (!(flags & TCL_GLOBAL_ONLY)) { - flags |= TCL_NAMESPACE_ONLY; - } - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the variable in the variable table of its namespace. Be sure Index: generic/tclZlib.c ================================================================== --- generic/tclZlib.c +++ generic/tclZlib.c @@ -371,11 +371,11 @@ * listed above. */ default: TclNewLiteralStringObj(objv[2], "UNKNOWN"); - TclNewLongObj(objv[3], code); + TclNewIntObj(objv[3], code); return Tcl_NewListObj(4, objv); } } /* Index: library/init.tcl ================================================================== --- library/init.tcl +++ library/init.tcl @@ -14,11 +14,11 @@ # This test intentionally written in pre-7.5 Tcl if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 9.0a0 +package require -exact Tcl 8.7a2 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: # # The environment variable TCLLIBPATH @@ -71,47 +71,10 @@ if {$Dir ni $Path} { lappend Path $Dir encoding dirs $Path } } - - # TIP #255 min and max functions - namespace eval mathfunc { - proc min {args} { - if {![llength $args]} { - return -code error \ - "too few arguments to math function \"min\"" - } - set val Inf - foreach arg $args { - # This will handle forcing the numeric value without - # ruining the internal type of a numeric object - if {[catch {expr {double($arg)}} err]} { - return -code error $err - } - if {$arg < $val} {set val $arg} - } - return $val - } - proc max {args} { - if {![llength $args]} { - return -code error \ - "too few arguments to math function \"max\"" - } - set val -Inf - foreach arg $args { - # This will handle forcing the numeric value without - # ruining the internal type of a numeric object - if {[catch {expr {double($arg)}} err]} { - return -code error $err - } - if {$arg > $val} {set val $arg} - } - return $val - } - namespace export min max - } } namespace eval tcl::Pkg {} # Windows specific end of initialization @@ -654,12 +617,11 @@ return $auto_execs($name) } set auto_execs($name) "" set shellBuiltins [list assoc cls copy date del dir echo erase ftype \ - md mkdir mklink move rd ren rename rmdir start \ - time type ver vol] + md mkdir mklink move rd ren rename rmdir start time type ver vol] if {[info exists env(PATHEXT)]} { # Add an initial ; to have the {} extension check first. set execExtensions [split ";$env(PATHEXT)" ";"] } else { set execExtensions [list {} .com .exe .bat .cmd] @@ -689,14 +651,11 @@ set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { set windir $env(WINDIR) } if {[info exists windir]} { - if {$tcl_platform(os) eq "Windows NT"} { - append path "$windir/system32;" - } - append path "$windir/system;$windir;" + append path "$windir/system32;$windir/system;$windir;" } foreach var {PATH Path path} { if {[info exists env($var)]} { append path ";$env($var)" Index: library/safe.tcl ================================================================== --- library/safe.tcl +++ library/safe.tcl @@ -111,11 +111,11 @@ # This is even more complicated by the boolean flags with no values that # we had the bad idea to support for the sake of user simplicity in # create/init but which makes life hard in configure... # So this will be hopefully written and some integrated with opt1.0 -# (hopefully for tcl9.0 ?) +# (hopefully for tcl8.1 ?) proc ::safe::interpConfigure {args} { switch [llength $args] { 1 { # If we have exactly 1 argument the semantic is to return all # the current configuration. We still call OptKeyParse though Index: macosx/README ================================================================== --- macosx/README +++ macosx/README @@ -111,11 +111,11 @@ Note that the non-SDK configurations have their deployment target set to 10.5 (Tcl.xcode) resp. 10.6 (Tcl.xcodeproj). The Xcode projects refer to the toplevel tcl source directory via the TCL_SRCROOT user build setting, by default this is set to the project-relative path '../../tcl', if your tcl source directory is named differently, e.g. -'../../tcl9.0', you need to manually change the TCL_SRCROOT setting by editing +'../../tcl8.7', you need to manually change the TCL_SRCROOT setting by editing your ${USER}.pbxuser file (located inside the Tcl.xcodeproj bundle directory) with a text editor. - To build universal binaries outside of the Xcode IDE, set CFLAGS as follows: export CFLAGS="-arch i386 -arch x86_64 -arch ppc" @@ -139,13 +139,13 @@ ---------------------------------------------------------- - Unpack the Tcl source release archive. - The following instructions assume the Tcl source tree is named "tcl${ver}", -(where ${ver} is a shell variable containing the Tcl version number e.g. '9.0'). +(where ${ver} is a shell variable containing the Tcl version number e.g. '8.7'). Setup this shell variable as follows: - ver="9.0" + ver="8.7" If you are building from CVS, omit this step (CVS source tree names usually do not contain a version number). - Setup environment variables as desired, e.g. for a universal build on 10.5: CFLAGS="-arch i386 -arch x86_64 -arch ppc -mmacosx-version-min=10.5" Index: macosx/Tcl-Common.xcconfig ================================================================== --- macosx/Tcl-Common.xcconfig +++ macosx/Tcl-Common.xcconfig @@ -32,6 +32,6 @@ PREFIX = /usr/local TCL_CONFIGURE_ARGS = --enable-threads --enable-dtrace TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION) TCL_PACKAGE_PATH = "$(LIBDIR)" TCL_DEFS = HAVE_TCL_CONFIG_H -VERSION = 9.0 +VERSION = 8.7 Index: tests/assemble.test ================================================================== --- tests/assemble.test +++ tests/assemble.test @@ -779,11 +779,11 @@ assemble { push NaN; uplus } } -returnCodes error - -result {can't use non-numeric floating-point value "NaN" as operand of "+"} + -result {can't use non-numeric floating-point value as operand of "+"} } test assemble-7.43.1 {tryCvtToNumeric} { -body { assemble { push NaN; tryCvtToNumeric Index: tests/basic.test ================================================================== --- tests/basic.test +++ tests/basic.test @@ -981,10 +981,20 @@ testevalex {set ::context $x} global } namespace delete ns set ::context } {global} + +test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup { + interp create slave + interp alias {} foo slave return +} -body { + list [catch foo m] $m +} -cleanup { + unset -nocomplain m + interp delete slave +} -result {0 {}} # Clean up after expand tests unset noComp l1 l2 constraints rename l3 {} rename run {} Index: tests/chanio.test ================================================================== --- tests/chanio.test +++ tests/chanio.test @@ -5864,10 +5864,12 @@ list [testfevent cmd "chan event $f readable"] [chan event $f readable] } -constraints {testfevent fileevent} -cleanup { testfevent delete chan close $f } -result {{script 1} {}} +unset path(foo) +removeFile foo set path(bar) [makeFile {} bar] test chan-io-48.1 {testing readability conditions} {fileevent} { set f [open $path(bar) w] @@ -5959,10 +5961,13 @@ vwait [namespace which -variable x] list $x $l } -cleanup { chan close $f } -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +unset path(bar) +removeFile bar + test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup { file delete $path(test1) set c 0 set l "" } -constraints {fileevent} -body { @@ -6788,12 +6793,10 @@ chan configure $out -encoding koi8-r -translation lf chan copy $in $out chan close $in chan close $out file size $path(kyrillic.txt) -} -cleanup { - file delete $path(utf8-fcopy.txt) } -result 3 test chan-io-53.1 {CopyData} -setup { file delete $path(test1) } -constraints {fcopy} -body { Index: tests/cmdIL.test ================================================================== --- tests/cmdIL.test +++ tests/cmdIL.test @@ -17,10 +17,11 @@ catch [list package require -exact Tcltest [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] +testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body { lsort } -result {wrong # args: should be "lsort ?-option value ...? list"} test cmdIL-1.2 {Tcl_LsortObjCmd procedure} -returnCodes error -body { @@ -145,10 +146,22 @@ lsort -stride 2 -index {0 1} { {{c o d e} 54321} {{b l a h} 94729} {{b i g} 12345} {{d e m o} 34512} } } {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}} +test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii -nocase [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf { + lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] +test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf { + lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] # Can't think of any good tests for the MergeSort and MergeLists procedures, # except a bunch of random lists to sort. test cmdIL-2.1 {MergeSort and MergeLists procedures} -setup { Index: tests/compExpr-old.test ================================================================== --- tests/compExpr-old.test +++ tests/compExpr-old.test @@ -18,16 +18,10 @@ } ::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 {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c @@ -283,14 +277,14 @@ test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { expr 2^x } -returnCodes error -match glob -result * test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "^"}} +} {1 {can't use floating-point value as operand of "^"}} test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "^"}} +} {1 {can't use non-numeric string as operand of "^"}} test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 test compExpr-old-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 test compExpr-old-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 @@ -307,14 +301,14 @@ test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { expr 2&x } -returnCodes error -match glob -result * test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "&"}} +} {1 {can't use floating-point value as operand of "&"}} test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "&"}} +} {1 {can't use non-numeric string as operand of "&"}} test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 test compExpr-old-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1 test compExpr-old-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0 @@ -375,14 +369,14 @@ test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body { expr 2<>43}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of ">>"}} +} {1 {can't use floating-point value as operand of ">>"}} test compExpr-old-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "<<"}} +} {1 {can't use non-numeric string as operand of "<<"}} test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 test compExpr-old-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 test compExpr-old-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0o123} 6 @@ -397,14 +391,14 @@ test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body { expr 2-x } -returnCodes error -match glob -result * test compExpr-old-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test compExpr-old-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} test compExpr-old-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} test compExpr-old-11.13a {CompileAddExpr: runtime error} ieeeFloatingPoint { list [catch {expr {2.3/0.0}} msg] $msg @@ -428,14 +422,14 @@ test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { expr 2*x } -returnCodes error -match glob -result * test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "*"}} +} {1 {can't use non-numeric string as operand of "*"}} test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83 test compExpr-old-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 test compExpr-old-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 @@ -449,14 +443,14 @@ expr !1.x set msg } -returnCodes error -match glob -result * test compExpr-old-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "~"}} +} {1 {can't use non-numeric string as operand of "~"}} test compExpr-old-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value "4.0" as operand of "~"}} +} {1 {can't use floating-point value as operand of "~"}} test compExpr-old-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 test compExpr-old-13.13 {CompileUnaryExpr: just primary expr} { set a 27 expr $a } 27 @@ -600,26 +594,10 @@ while *ing "expr pow(1)"} 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 set i 123 if {[expr 0x$a(VALUE)] & 16} { Index: tests/compExpr.test ================================================================== --- tests/compExpr.test +++ tests/compExpr.test @@ -14,16 +14,10 @@ } ::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]] catch {unset a} @@ -317,16 +311,10 @@ format %.6g [expr atan2(1.0, 2.0)] } 0.463648 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*} test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] Index: tests/compile.test ================================================================== --- tests/compile.test +++ tests/compile.test @@ -321,11 +321,11 @@ test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; string index a bogus }} } -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; string index a 0o9 }} -} -returnCodes error -match glob -result {*} +} -returnCodes error -match glob -result {*invalid octal number*} test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; array set var {one two many} }} } -returnCodes error -result {list must have an even number of elements} test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; incr foo bar baz}} Index: tests/exec.test ================================================================== --- tests/exec.test +++ tests/exec.test @@ -298,11 +298,10 @@ } "second msg\nfoo bar" # I/O redirection: combinations. set path(gorp.file2) [makeFile {} gorp.file2] -file delete $path(gorp.file2) test exec-7.1 {multiple I/O redirections} {exec} { exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file) exec [interpreter] $path(cat) $path(gorp.file2) } {Just a few thoughts} Index: tests/execute.test ================================================================== --- tests/execute.test +++ tests/execute.test @@ -172,11 +172,11 @@ expr {$x + 1} } 2.0 test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {$x + 1}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 + $x} } 2 test execute-3.8 {TclExecuteByteCode, INST_ADD, op2 is double} {testobj} { @@ -197,11 +197,11 @@ expr {1 + $x} } 2.0 test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {1 + $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} # INST_SUB is partially tested: test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} { set x [testintobj set 0 1] expr {$x - 1} @@ -224,11 +224,11 @@ expr {$x - 1} } 0.0 test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {$x - 1}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 - $x} } 0 test execute-3.20 {TclExecuteByteCode, INST_SUB, op2 is double} {testobj} { @@ -249,11 +249,11 @@ expr {1 - $x} } 0.0 test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {1 - $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} # INST_MULT is partially tested: test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} { set x [testintobj set 1 1] expr {$x * 1} @@ -276,11 +276,11 @@ expr {$x * 1} } 1.0 test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {$x * 1}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "*"}} +} {1 {can't use non-numeric string as operand of "*"}} test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} { set x [testintobj set 1 1] expr {1 * $x} } 1 test execute-3.32 {TclExecuteByteCode, INST_MULT, op2 is double} {testobj} { @@ -301,11 +301,11 @@ expr {1 * $x} } 1.0 test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {1 * $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "*"}} +} {1 {can't use non-numeric string as operand of "*"}} # INST_DIV is partially tested: test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} { set x [testintobj set 1 1] expr {$x / 1} @@ -328,11 +328,11 @@ expr {$x / 1} } 1.0 test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {$x / 1}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} { set x [testintobj set 1 1] expr {2 / $x} } 2 test execute-3.44 {TclExecuteByteCode, INST_DIV, op2 is double} {testobj} { @@ -353,11 +353,11 @@ expr {2 / $x} } 2.0 test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {1 / $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} # INST_UPLUS is partially tested: test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} { set x [testintobj set 1 1] expr {+ $x} @@ -380,11 +380,11 @@ expr {+ $x} } 1.0 test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {+ $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} # INST_UMINUS is partially tested: test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} { set x [testintobj set 1 1] expr {- $x} @@ -407,11 +407,11 @@ expr {- $x} } -1.0 test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {- $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} # INST_LNOT is partially tested: test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { set x [testintobj set 1 2] expr {! $x} @@ -455,11 +455,11 @@ expr {! $x} } 1 test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {! $x}} msg] $msg -} {1 {can't use non-numeric string "foo" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} # INST_BITNOT not tested # INST_CALL_BUILTIN_FUNC1 not tested # INST_CALL_FUNC1 not tested Index: tests/expr-old.test ================================================================== --- tests/expr-old.test +++ tests/expr-old.test @@ -22,16 +22,10 @@ testConstraint testexprlong [llength [info commands testexprlong]] 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 {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c @@ -195,38 +189,38 @@ # Operators that aren't legal on floating-point numbers test expr-old-3.1 {illegal floating-point operations} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value "4.0" as operand of "~"}} +} {1 {can't use floating-point value as operand of "~"}} test expr-old-3.2 {illegal floating-point operations} { list [catch {expr 27%4.0} msg] $msg -} {1 {can't use floating-point value "4.0" as operand of "%"}} +} {1 {can't use floating-point value as operand of "%"}} test expr-old-3.3 {illegal floating-point operations} { list [catch {expr 27.0%4} msg] $msg -} {1 {can't use floating-point value "27.0" as operand of "%"}} +} {1 {can't use floating-point value as operand of "%"}} test expr-old-3.4 {illegal floating-point operations} { list [catch {expr 1.0<<3} msg] $msg -} {1 {can't use floating-point value "1.0" as operand of "<<"}} +} {1 {can't use floating-point value as operand of "<<"}} test expr-old-3.5 {illegal floating-point operations} { list [catch {expr 3<<1.0} msg] $msg -} {1 {can't use floating-point value "1.0" as operand of "<<"}} +} {1 {can't use floating-point value as operand of "<<"}} test expr-old-3.6 {illegal floating-point operations} { list [catch {expr 24.0>>3} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of ">>"}} +} {1 {can't use floating-point value as operand of ">>"}} test expr-old-3.7 {illegal floating-point operations} { list [catch {expr 24>>3.0} msg] $msg -} {1 {can't use floating-point value "3.0" as operand of ">>"}} +} {1 {can't use floating-point value as operand of ">>"}} test expr-old-3.8 {illegal floating-point operations} { list [catch {expr 24&3.0} msg] $msg -} {1 {can't use floating-point value "3.0" as operand of "&"}} +} {1 {can't use floating-point value as operand of "&"}} test expr-old-3.9 {illegal floating-point operations} { list [catch {expr 24.0|3} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "|"}} +} {1 {can't use floating-point value as operand of "|"}} test expr-old-3.10 {illegal floating-point operations} { list [catch {expr 24.0^3} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "^"}} +} {1 {can't use floating-point value as operand of "^"}} # Check the string operators individually. test expr-old-4.1 {string operators} {expr {"abc" > "def"}} 0 test expr-old-4.2 {string operators} {expr {"def" > "def"}} 0 @@ -263,50 +257,50 @@ # Operators that aren't legal on string operands. test expr-old-5.1 {illegal string operations} { list [catch {expr {-"a"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} test expr-old-5.2 {illegal string operations} { list [catch {expr {+"a"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-5.3 {illegal string operations} { list [catch {expr {~"a"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "~"}} +} {1 {can't use non-numeric string as operand of "~"}} test expr-old-5.4 {illegal string operations} { list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-old-5.5 {illegal string operations} { list [catch {expr {"a"*"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "*"}} +} {1 {can't use non-numeric string as operand of "*"}} test expr-old-5.6 {illegal string operations} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} test expr-old-5.7 {illegal string operations} { list [catch {expr {"a"%"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "%"}} +} {1 {can't use non-numeric string as operand of "%"}} test expr-old-5.8 {illegal string operations} { list [catch {expr {"a"+"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-5.9 {illegal string operations} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} test expr-old-5.10 {illegal string operations} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "<<"}} +} {1 {can't use non-numeric string as operand of "<<"}} test expr-old-5.11 {illegal string operations} { list [catch {expr {"a">>"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of ">>"}} +} {1 {can't use non-numeric string as operand of ">>"}} test expr-old-5.12 {illegal string operations} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "&"}} +} {1 {can't use non-numeric string as operand of "&"}} test expr-old-5.13 {illegal string operations} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "^"}} +} {1 {can't use non-numeric string as operand of "^"}} test expr-old-5.14 {illegal string operations} { list [catch {expr {"a"|"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "|"}} +} {1 {can't use non-numeric string as operand of "|"}} test expr-old-5.15 {illegal string operations} { list [catch {expr {"a"&&"b"}} msg] $msg } {1 {expected boolean value but got "a"}} test expr-old-5.16 {illegal string operations} { list [catch {expr {"a"||"b"}} msg] $msg @@ -491,11 +485,11 @@ # Various error conditions. test expr-old-26.1 {error conditions} { list [catch {expr 2+"a"} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-26.2 {error conditions} -body { expr 2+4* } -returnCodes error -match glob -result * test expr-old-26.3 {error conditions} -body { expr 2+4*( @@ -505,14 +499,14 @@ list [catch {expr 2+$_non_existent_} msg] $msg } {1 {can't read "_non_existent_": no such variable}} set a xx test expr-old-26.5 {error conditions} { list [catch {expr {2+$a}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-26.6 {error conditions} { list [catch {expr {2+[set a]}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-26.7 {error conditions} -body { expr {2+(4} } -returnCodes error -match glob -result * test expr-old-26.8 {error conditions} { list [catch {expr 2/0} msg] $msg $errorCode @@ -532,11 +526,11 @@ test expr-old-26.12 {error conditions} -body { expr a.b } -returnCodes error -match glob -result * test expr-old-26.13 {error conditions} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} test expr-old-26.14 {error conditions} -body { expr 2:3 } -returnCodes error -match glob -result * test expr-old-26.15 {error conditions} -body { expr a@b @@ -845,16 +839,10 @@ list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg } {0 16.0} 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} test expr-old-32.46 {math functions in expressions} -body { list [catch {expr rand(24)} msg] $msg @@ -950,22 +938,17 @@ expr round(1.0e30) } 1000000000000000019884624838656 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*} test expr-old-36.2 {ExprLooksLikeInt procedure} { set x 0o289 list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string "0o289" as operand of "+"}} +} {1 {can't use invalid octal number as operand of "+"}} test expr-old-36.3 {ExprLooksLikeInt procedure} { list [catch {expr 0289.1} msg] $msg } {0 289.1} test expr-old-36.4 {ExprLooksLikeInt procedure} { set x 0289.1 @@ -1001,23 +984,23 @@ # tests for [Bug #587140] test expr-old-36.12 {ExprLooksLikeInt procedure} { set x "10;" list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string "10;" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-36.13 {ExprLooksLikeInt procedure} { set x " +" list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string " +" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-old-36.14 {ExprLooksLikeInt procedure} { set x "123456789012345678901234567890 " expr {$x+1} } 123456789012345678901234567891 test expr-old-36.15 {ExprLooksLikeInt procedure} { set x "0o99 " list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string "0o99 " as operand of "+"}} +} {1 {can't use invalid octal number as operand of "+"}} test expr-old-36.16 {ExprLooksLikeInt procedure} { set x " 0xffffffffffffffffffffffffffffffffffffff " expr {$x+1} } [expr 0x100000000000000000000000000000000000000] @@ -1157,40 +1140,52 @@ } -result 0 test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { - list [catch {expr {min()}} msg] $msg -} -result {1 {too few arguments to math function "min"}} + expr {min()} +} -returnCodes error -result {too few arguments for math function "min"} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] test expr-old-40.5 {min math function} -body { expr {min("a", 0)} } -returnCodes error -match glob -result * test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 +test expr-old-40.7 {min math function} -body { + expr min(1[string repeat 0 10000], 1e300) +} -result 1e+300 +test expr-old-40.8 {min math function} -body { + expr {min(0, "a")} +} -returnCodes error -match glob -result * test expr-old-41.1 {max math function} -body { expr {max(0)} } -result 0 test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { - list [catch {expr {max()}} msg] $msg -} -result {1 {too few arguments to math function "max"}} + expr {max()} +} -returnCodes error -result {too few arguments for math function "max"} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] test expr-old-41.5 {max math function} -body { expr {max("a", 0)} } -returnCodes error -match glob -result * test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 +test expr-old-41.7 {max math function} -body { + expr max(1[string repeat 0 10000], 1e300) +} -result 1[string repeat 0 10000] +test expr-old-41.8 {max math function} -body { + expr {max(0, "a")} +} -returnCodes error -match glob -result * # Special test for Pentium arithmetic bug of 1994: if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { puts "Warning: this machine contains a defective Pentium processor" Index: tests/expr.test ================================================================== --- tests/expr.test +++ tests/expr.test @@ -16,14 +16,10 @@ } ::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. testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] @@ -255,11 +251,11 @@ set i 7 expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} } 1 test expr-4.10 {CompileLorExpr: error compiling ! operand} { list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-4.11 {CompileLorExpr: error compiling land arms} { list [catch {expr {"a"||0}} msg] $msg } {1 {expected boolean value but got "a"}} test expr-4.12 {CompileLorExpr: error compiling land arms} { list [catch {expr {0||"a"}} msg] $msg @@ -302,14 +298,14 @@ test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { expr 2^x } -returnCodes error -match glob -result * test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "^"}} +} {1 {can't use floating-point value as operand of "^"}} test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "^"}} +} {1 {can't use non-numeric string as operand of "^"}} test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1 test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0 @@ -326,14 +322,14 @@ test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { expr 2&x } -returnCodes error -match glob -result * test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of "&"}} +} {1 {can't use floating-point value as operand of "&"}} test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "&"}} +} {1 {can't use non-numeric string as operand of "&"}} test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0 test expr-7.20 {CompileBitAndExpr: error in equality expr} -body { expr xne3 } -returnCodes error -match glob -result * @@ -454,14 +450,14 @@ test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body { expr 2<>43}} msg] $msg -} {1 {can't use floating-point value "24.0" as operand of ">>"}} +} {1 {can't use floating-point value as operand of ">>"}} test expr-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "<<"}} +} {1 {can't use non-numeric string as operand of "<<"}} test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1 test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0o123} 6 @@ -476,14 +472,14 @@ test expr-11.9 {CompileAddExpr: error compiling add arm} -body { expr 2-x } -returnCodes error -match glob -result * test expr-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test expr-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "-"}} +} {1 {can't use non-numeric string as operand of "-"}} test expr-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} test expr-11.13a {CompileAddExpr: runtime error} !ieeeFloatingPoint { list [catch {expr {2.3/0.0}} msg] $msg @@ -507,14 +503,14 @@ test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { expr 2*x } -returnCodes error -match glob -result * test expr-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "*"}} +} {1 {can't use non-numeric string as operand of "*"}} test expr-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "/"}} +} {1 {can't use non-numeric string as operand of "/"}} test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83 test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36 test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0 @@ -527,14 +523,14 @@ test expr-13.9 {CompileUnaryExpr: error compiling unary expr} -body { expr !1.x } -returnCodes error -match glob -result * test expr-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "~"}} +} {1 {can't use non-numeric string as operand of "~"}} test expr-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value "4.0" as operand of "~"}} +} {1 {can't use floating-point value as operand of "~"}} test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 test expr-13.13 {CompileUnaryExpr: just primary expr} { set a 27 expr $a } 27 @@ -683,45 +679,10 @@ while *ing "expr pow(1)"} 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} { catch {unset a} set a(VALUE) ff15 @@ -842,19 +803,19 @@ test expr-21.13 {non-numeric boolean literals} -body { expr !truef } -returnCodes error -match glob -result * test expr-21.14 {non-numeric boolean literals} { list [catch {expr !"truef"} err] $err -} {1 {can't use non-numeric string "truef" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-21.15 {non-numeric boolean variables} { set v truef list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string "truef" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-21.16 {non-numeric boolean variables} { set v "true " list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string "true " as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-21.17 {non-numeric boolean variables} { set v "tru" list [catch {expr {!$v}} err] $err } {0 0} test expr-21.18 {non-numeric boolean variables} { @@ -870,27 +831,27 @@ list [catch {expr {!$v}} err] $err } {0 1} test expr-21.21 {non-numeric boolean variables} { set v "o" list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string "o" as operand of "!"}} +} {1 {can't use non-numeric string as operand of "!"}} test expr-21.22 {non-numeric boolean variables} { set v "" list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string "" as operand of "!"}} +} {1 {can't use empty string as operand of "!"}} # Test for non-numeric float handling. test expr-22.1 {non-numeric floats} { list [catch {expr {NaN + 1}} msg] $msg -} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}} +} {1 {can't use non-numeric floating-point value as operand of "+"}} test expr-22.2 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {Inf + 1}} msg] $msg } {1 {can't use infinite floating-point value as operand of "+"}} test expr-22.3 {non-numeric floats} { set nan NaN list [catch {expr {$nan + 1}} msg] $msg -} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}} +} {1 {can't use non-numeric floating-point value as operand of "+"}} test expr-22.4 {non-numeric floats} !ieeeFloatingPoint { set inf Inf list [catch {expr {$inf + 1}} msg] $msg } {1 {can't use infinite floating-point value as operand of "+"}} test expr-22.5 {non-numeric floats} { @@ -899,11 +860,11 @@ test expr-22.6 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr Inf} msg] $msg } {1 {floating-point value too large to represent}} test expr-22.7 {non-numeric floats} { list [catch {expr {1 / NaN}} msg] $msg -} {1 {can't use non-numeric floating-point value "NaN" as operand of "/"}} +} {1 {can't use non-numeric floating-point value as operand of "/"}} test expr-22.8 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {1 / Inf}} msg] $msg } {1 {can't use infinite floating-point value as operand of "/"}} # Make sure [Bug 761471] stays fixed. test expr-22.9 {non-numeric floats: shared object equality and NaN} { @@ -935,14 +896,14 @@ test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body { expr 2**x } -returnCodes error -match glob -result * test expr-23.9 {CompileExponentialExpr: runtime error} { list [catch {expr {24.0**"xx"}} msg] $msg -} {1 {can't use non-numeric string "xx" as operand of "**"}} +} {1 {can't use non-numeric string as operand of "**"}} test expr-23.10 {CompileExponentialExpr: runtime error} { list [catch {expr {"a"**2}} msg] $msg -} {1 {can't use non-numeric string "a" as operand of "**"}} +} {1 {can't use non-numeric string as operand of "**"}} test expr-23.11 {CompileExponentialExpr: runtime error} { list [catch {expr {0**-1}} msg] $msg } {1 {exponentiation of zero by negative power}} test expr-23.12 {CompileExponentialExpr: runtime error} { list [catch {expr {0.0**-1.0}} msg] $msg Index: tests/fileSystem.test ================================================================== --- tests/fileSystem.test +++ tests/fileSystem.test @@ -375,10 +375,26 @@ test filesystem-1.52.1 {bug f9f390d0fa: file join where strep is not canonical} -body { set x //foo file normalize $x file join $x } -result /foo +test filesystem-1.53 {[Bug 3559678] - normalize when tail is empty} { + string match */ [file normalize [lindex [glob -dir [pwd] {{}}] 0]] +} 0 +test filesystem-1.54 {[Bug ce3a211dcb] - normalize when tail is empty} -setup { + set save [pwd] + cd [set home [makeDirectory ce3a211dcb]] + makeDirectory A $home + cd [lindex [glob */] 0] +} -body { + string match */A [pwd] +} -cleanup { + cd $home + removeDirectory A $home + cd $save + removeDirectory ce3a211dcb +} -result 1 test filesystem-2.0 {new native path} {unix} { foreach f [lsort [glob -nocomplain /usr/bin/c*]] { catch {file readlink $f} } Index: tests/get.test ================================================================== --- tests/get.test +++ tests/get.test @@ -96,21 +96,21 @@ } set result } {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}} # Bug 7114ac6141 test get-3.3 {tcl_GetInt with iffy numbers} testgetint { - lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} { + lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} { catch {testgetint 44 $x} x set x } -} {44 44 44 44 54 54 52 46} +} {44 44 44 44 54 51 52 46} test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { - lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} { + lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} { catch {testdoubleobj set 1 $x} x set x } -} {0.0 0.0 0.0 0.0 0.0 9.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0} +} {0.0 0.0 0.0 0.0 0.0 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0} # cleanup ::tcltest::cleanupTests return Index: tests/info.test ================================================================== --- tests/info.test +++ tests/info.test @@ -2396,11 +2396,11 @@ } -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- unset -nocomplain res -test info-39.0 {Bug 4b61afd660} -setup { +test info-39.2 {Bug 4b61afd660} -setup { proc probe {} { return [dict get [info frame -1] line] } set body { set cmd probe Index: tests/interp.test ================================================================== --- tests/interp.test +++ tests/interp.test @@ -1845,11 +1845,11 @@ lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a alias bar {} lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] } -cleanup { interp delete a -} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] +} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds] test interp-24.1 {result resetting on error} -setup { catch {interp delete a} } -body { interp create a Index: tests/io.test ================================================================== --- tests/io.test +++ tests/io.test @@ -6161,10 +6161,12 @@ [fileevent $f readable]] testfevent delete close $f set x } {{script 1} {}} +unset path(foo) +removeFile foo set path(bar) [makeFile {} bar] test io-48.1 {testing readability conditions} {fileevent} { set f [open $path(bar) w] @@ -6263,10 +6265,13 @@ puts $f {exit} vwait [namespace which -variable x] close $f list $x $l } {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +unset path(bar) +removeFile bar + test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -translation lf variable c [format "abc\ndef\n%c" 26] Index: tests/ioCmd.test ================================================================== --- tests/ioCmd.test +++ tests/ioCmd.test @@ -382,11 +382,10 @@ } 0 set path(test4) [makeFile {} test4] set path(test5) [makeFile {} test5] -file delete $path(test5) test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { set f [open $path(test4) w] close $f list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode } {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}} @@ -3834,10 +3833,8 @@ foreach file [list test1 test2 test3 test4] { removeFile $file } # delay long enough for background processes to finish after 500 -foreach file [list test5] { - removeFile $file -} +removeFile test5 cleanupTests return Index: tests/lindex.test ================================================================== --- tests/lindex.test +++ tests/lindex.test @@ -68,15 +68,15 @@ list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} test lindex-3.5 {bad octal} -constraints testevalex -body { set x 0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-3.6 {bad octal} -constraints testevalex -body { set x -0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-3.7 {indexes don't shimmer wide ints} { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] } {2147483646 {} 2147483647 2147483648} @@ -103,15 +103,15 @@ list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {{} {}} test lindex-4.6 {bad octal} -constraints testevalex -body { set x end-0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-4.7 {bad octal} -constraints testevalex -body { set x end--0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-4.8 {bad integer, not octal} testevalex { set x end-0a2 list [catch { testevalex {lindex {a b c} $x} } result] $result } {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-4.9 {obsolete test} testevalex { @@ -259,15 +259,15 @@ set result } {{} {}} test lindex-11.5 {bad octal} -body { set x 0o8 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-11.6 {bad octal} -body { set x -0o9 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} # Indices relative to end test lindex-12.1 {index = end} { set x end @@ -305,15 +305,15 @@ set result } {{} {}} test lindex-12.6 {bad octal} -body { set x end-0o8 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-12.7 {bad octal} -body { set x end--0o9 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test lindex-12.8 {bad integer, not octal} { set x end-0a2 list [catch { lindex {a b c} $x } result] $result } {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}} test lindex-12.9 {obsolete test} { Index: tests/mathop.test ================================================================== --- tests/mathop.test +++ tests/mathop.test @@ -112,26 +112,26 @@ test mathop-1.8 {compiled +} { + 1 2 300000000000 } 300000000003 test mathop-1.9 {compiled +} { + 1000000000000000000000 2 3 } 1000000000000000000005 test mathop-1.10 {compiled +} { + 1 2 3000000000000000000000 } 3000000000000000000003 test mathop-1.11 {compiled +: errors} -returnCodes error -body { + x 0 - } -result {can't use non-numeric string "x" as operand of "+"} + } -result {can't use non-numeric string as operand of "+"} test mathop-1.12 {compiled +: errors} -returnCodes error -body { + nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "+"} + } -result {can't use non-numeric floating-point value as operand of "+"} test mathop-1.13 {compiled +: errors} -returnCodes error -body { + 0 x - } -result {can't use non-numeric string "x" as operand of "+"} + } -result {can't use non-numeric string as operand of "+"} test mathop-1.14 {compiled +: errors} -returnCodes error -body { + 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "+"} + } -result {can't use non-numeric floating-point value as operand of "+"} test mathop-1.15 {compiled +: errors} -returnCodes error -body { + 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "+"} + } -result {can't use invalid octal number as operand of "+"} test mathop-1.16 {compiled +: errors} -returnCodes error -body { + 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "+"} + } -result {can't use invalid octal number as operand of "+"} test mathop-1.17 {compiled +: errors} -returnCodes error -body { + 0 [error expectedError] } -result expectedError test mathop-1.18 {compiled +: argument processing order} -body { # Bytecode compilation known hard for 3+ arguments @@ -150,26 +150,26 @@ test mathop-1.26 {interpreted +} { $op 1 2 300000000000 } 300000000003 test mathop-1.27 {interpreted +} { $op 1000000000000000000000 2 3 } 1000000000000000000005 test mathop-1.28 {interpreted +} { $op 1 2 3000000000000000000000 } 3000000000000000000003 test mathop-1.29 {interpreted +: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string "x" as operand of "+"} + } -result {can't use non-numeric string as operand of "+"} test mathop-1.30 {interpreted +: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "+"} + } -result {can't use non-numeric floating-point value as operand of "+"} test mathop-1.31 {interpreted +: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string "x" as operand of "+"} + } -result {can't use non-numeric string as operand of "+"} test mathop-1.32 {interpreted +: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "+"} + } -result {can't use non-numeric floating-point value as operand of "+"} test mathop-1.33 {interpreted +: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "+"} + } -result {can't use invalid octal number as operand of "+"} test mathop-1.34 {interpreted +: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "+"} + } -result {can't use invalid octal number as operand of "+"} test mathop-1.35 {interpreted +: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError test mathop-1.36 {interpreted +: argument processing order} -body { list [catch { @@ -187,26 +187,26 @@ test mathop-2.8 {compiled *} { * 1 2 300000000000 } 600000000000 test mathop-2.9 {compiled *} { * 1000000000000000000000 2 3 } 6000000000000000000000 test mathop-2.10 {compiled *} { * 1 2 3000000000000000000000 } 6000000000000000000000 test mathop-2.11 {compiled *: errors} -returnCodes error -body { * x 0 - } -result {can't use non-numeric string "x" as operand of "*"} + } -result {can't use non-numeric string as operand of "*"} test mathop-2.12 {compiled *: errors} -returnCodes error -body { * nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "*"} + } -result {can't use non-numeric floating-point value as operand of "*"} test mathop-2.13 {compiled *: errors} -returnCodes error -body { * 0 x - } -result {can't use non-numeric string "x" as operand of "*"} + } -result {can't use non-numeric string as operand of "*"} test mathop-2.14 {compiled *: errors} -returnCodes error -body { * 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "*"} + } -result {can't use non-numeric floating-point value as operand of "*"} test mathop-2.15 {compiled *: errors} -returnCodes error -body { * 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "*"} + } -result {can't use invalid octal number as operand of "*"} test mathop-2.16 {compiled *: errors} -returnCodes error -body { * 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "*"} + } -result {can't use invalid octal number as operand of "*"} test mathop-2.17 {compiled *: errors} -returnCodes error -body { * 0 [error expectedError] } -result expectedError test mathop-2.18 {compiled *: argument processing order} -body { # Bytecode compilation known hard for 3+ arguments @@ -225,26 +225,26 @@ test mathop-2.26 {interpreted *} { $op 1 2 300000000000 } 600000000000 test mathop-2.27 {interpreted *} { $op 1000000000000000000000 2 3 } 6000000000000000000000 test mathop-2.28 {interpreted *} { $op 1 2 3000000000000000000000 } 6000000000000000000000 test mathop-2.29 {interpreted *: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string "x" as operand of "*"} + } -result {can't use non-numeric string as operand of "*"} test mathop-2.30 {interpreted *: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "*"} + } -result {can't use non-numeric floating-point value as operand of "*"} test mathop-2.31 {interpreted *: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string "x" as operand of "*"} + } -result {can't use non-numeric string as operand of "*"} test mathop-2.32 {interpreted *: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "*"} + } -result {can't use non-numeric floating-point value as operand of "*"} test mathop-2.33 {interpreted *: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "*"} + } -result {can't use invalid octal number as operand of "*"} test mathop-2.34 {interpreted *: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "*"} + } -result {can't use invalid octal number as operand of "*"} test mathop-2.35 {interpreted *: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError test mathop-2.36 {interpreted *: argument processing order} -body { list [catch { @@ -259,11 +259,11 @@ test mathop-3.5 {compiled !} {! 0.0} 1 test mathop-3.6 {compiled !} {! 10000000000} 0 test mathop-3.7 {compiled !} {! 10000000000000000000000000} 0 test mathop-3.8 {compiled !: errors} -body { ! foobar - } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"} + } -returnCodes error -result {can't use non-numeric string as operand of "!"} test mathop-3.9 {compiled !: errors} -body { ! 0 0 } -returnCodes error -result "wrong # args: should be \"! boolean\"" test mathop-3.10 {compiled !: errors} -body { ! @@ -276,23 +276,23 @@ test mathop-3.15 {interpreted !} {$op 0.0} 1 test mathop-3.16 {interpreted !} {$op 10000000000} 0 test mathop-3.17 {interpreted !} {$op 10000000000000000000000000} 0 test mathop-3.18 {interpreted !: errors} -body { $op foobar - } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"} + } -returnCodes error -result {can't use non-numeric string as operand of "!"} test mathop-3.19 {interpreted !: errors} -body { $op 0 0 } -returnCodes error -result "wrong # args: should be \"! boolean\"" test mathop-3.20 {interpreted !: errors} -body { $op } -returnCodes error -result "wrong # args: should be \"! boolean\"" test mathop-3.21 {compiled !: error} -returnCodes error -body { ! NaN - } -result {can't use non-numeric floating-point value "NaN" as operand of "!"} + } -result {can't use non-numeric floating-point value as operand of "!"} test mathop-3.22 {interpreted !: error} -returnCodes error -body { $op NaN - } -result {can't use non-numeric floating-point value "NaN" as operand of "!"} + } -result {can't use non-numeric floating-point value as operand of "!"} test mathop-4.1 {compiled ~} {~ 0} -1 test mathop-4.2 {compiled ~} {~ 1} -2 test mathop-4.3 {compiled ~} {~ 31} -32 test mathop-4.4 {compiled ~} {~ -127} 126 @@ -299,23 +299,23 @@ test mathop-4.5 {compiled ~} {~ -0} -1 test mathop-4.6 {compiled ~} {~ 10000000000} -10000000001 test mathop-4.7 {compiled ~} {~ 10000000000000000000000000} -10000000000000000000000001 test mathop-4.8 {compiled ~: errors} -body { ~ foobar - } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"} + } -returnCodes error -result {can't use non-numeric string as operand of "~"} test mathop-4.9 {compiled ~: errors} -body { ~ 0 0 } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.10 {compiled ~: errors} -body { ~ } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.11 {compiled ~: errors} -returnCodes error -body { ~ 0.0 - } -result {can't use floating-point value "0.0" as operand of "~"} + } -result {can't use floating-point value as operand of "~"} test mathop-4.12 {compiled ~: errors} -returnCodes error -body { ~ NaN - } -result {can't use non-numeric floating-point value "NaN" as operand of "~"} + } -result {can't use non-numeric floating-point value as operand of "~"} set op ~ test mathop-4.13 {interpreted ~} {$op 0} -1 test mathop-4.14 {interpreted ~} {$op 1} -2 test mathop-4.15 {interpreted ~} {$op 31} -32 test mathop-4.16 {interpreted ~} {$op -127} 126 @@ -322,23 +322,23 @@ test mathop-4.17 {interpreted ~} {$op -0} -1 test mathop-4.18 {interpreted ~} {$op 10000000000} -10000000001 test mathop-4.19 {interpreted ~} {$op 10000000000000000000000000} -10000000000000000000000001 test mathop-4.20 {interpreted ~: errors} -body { $op foobar - } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"} + } -returnCodes error -result {can't use non-numeric string as operand of "~"} test mathop-4.21 {interpreted ~: errors} -body { $op 0 0 } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.22 {interpreted ~: errors} -body { $op } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.23 {interpreted ~: errors} -returnCodes error -body { $op 0.0 - } -result {can't use floating-point value "0.0" as operand of "~"} + } -result {can't use floating-point value as operand of "~"} test mathop-4.24 {interpreted ~: errors} -returnCodes error -body { $op NaN - } -result {can't use non-numeric floating-point value "NaN" as operand of "~"} + } -result {can't use non-numeric floating-point value as operand of "~"} test mathop-5.1 {compiled eq} {eq {} a} 0 test mathop-5.2 {compiled eq} {eq a a} 1 test mathop-5.3 {compiled eq} {eq a {}} 0 test mathop-5.4 {compiled eq} {eq a b} 0 @@ -375,36 +375,36 @@ test mathop-6.2 {compiled &} { & 1 } 1 test mathop-6.3 {compiled &} { & 1 2 } 0 test mathop-6.4 {compiled &} { & 3 7 6 } 2 test mathop-6.5 {compiled &} -returnCodes error -body { & 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "&"} + } -result {can't use floating-point value as operand of "&"} test mathop-6.6 {compiled &} -returnCodes error -body { & 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "&"} + } -result {can't use floating-point value as operand of "&"} test mathop-6.7 {compiled &} { & 100000000002 18 -126 } 2 test mathop-6.8 {compiled &} { & 0xff 0o377 333333333333 } 85 test mathop-6.9 {compiled &} { & 1000000000000000000002 18 -126 } 2 test mathop-6.10 {compiled &} { & 0xff 0o377 3333333333333333333333 } 85 test mathop-6.11 {compiled &: errors} -returnCodes error -body { & x 0 - } -result {can't use non-numeric string "x" as operand of "&"} + } -result {can't use non-numeric string as operand of "&"} test mathop-6.12 {compiled &: errors} -returnCodes error -body { & nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "&"} + } -result {can't use non-numeric floating-point value as operand of "&"} test mathop-6.13 {compiled &: errors} -returnCodes error -body { & 0 x - } -result {can't use non-numeric string "x" as operand of "&"} + } -result {can't use non-numeric string as operand of "&"} test mathop-6.14 {compiled &: errors} -returnCodes error -body { & 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "&"} + } -result {can't use non-numeric floating-point value as operand of "&"} test mathop-6.15 {compiled &: errors} -returnCodes error -body { & 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "&"} + } -result {can't use invalid octal number as operand of "&"} test mathop-6.16 {compiled &: errors} -returnCodes error -body { & 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "&"} + } -result {can't use invalid octal number as operand of "&"} test mathop-6.17 {compiled &: errors} -returnCodes error -body { & 0 [error expectedError] } -result expectedError test mathop-6.18 {compiled &: argument processing order} -body { # Bytecode compilation known hard for 3+ arguments @@ -417,36 +417,36 @@ test mathop-6.20 {interpreted &} { $op 1 } 1 test mathop-6.21 {interpreted &} { $op 1 2 } 0 test mathop-6.22 {interpreted &} { $op 3 7 6 } 2 test mathop-6.23 {interpreted &} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "&"} + } -result {can't use floating-point value as operand of "&"} test mathop-6.24 {interpreted &} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "&"} + } -result {can't use floating-point value as operand of "&"} test mathop-6.25 {interpreted &} { $op 100000000002 18 -126 } 2 test mathop-6.26 {interpreted &} { $op 0xff 0o377 333333333333 } 85 test mathop-6.27 {interpreted &} { $op 1000000000000000000002 18 -126 } 2 test mathop-6.28 {interpreted &} { $op 0xff 0o377 3333333333333333333333 } 85 test mathop-6.29 {interpreted &: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string "x" as operand of "&"} + } -result {can't use non-numeric string as operand of "&"} test mathop-6.30 {interpreted &: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "&"} + } -result {can't use non-numeric floating-point value as operand of "&"} test mathop-6.31 {interpreted &: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string "x" as operand of "&"} + } -result {can't use non-numeric string as operand of "&"} test mathop-6.32 {interpreted &: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "&"} + } -result {can't use non-numeric floating-point value as operand of "&"} test mathop-6.33 {interpreted &: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "&"} + } -result {can't use invalid octal number as operand of "&"} test mathop-6.34 {interpreted &: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "&"} + } -result {can't use invalid octal number as operand of "&"} test mathop-6.35 {interpreted &: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError test mathop-6.36 {interpreted &: argument processing order} -body { list [catch { @@ -485,36 +485,36 @@ test mathop-7.2 {compiled |} { | 1 } 1 test mathop-7.3 {compiled |} { | 1 2 } 3 test mathop-7.4 {compiled |} { | 3 7 6 } 7 test mathop-7.5 {compiled |} -returnCodes error -body { | 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "|"} + } -result {can't use floating-point value as operand of "|"} test mathop-7.6 {compiled |} -returnCodes error -body { | 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "|"} + } -result {can't use floating-point value as operand of "|"} test mathop-7.7 {compiled |} { | 100000000002 18 -126 } -110 test mathop-7.8 {compiled |} { | 0xff 0o377 333333333333 } 333333333503 test mathop-7.9 {compiled |} { | 1000000000000000000002 18 -126 } -110 test mathop-7.10 {compiled |} { | 0xff 0o377 3333333333333333333333 } 3333333333333333333503 test mathop-7.11 {compiled |: errors} -returnCodes error -body { | x 0 - } -result {can't use non-numeric string "x" as operand of "|"} + } -result {can't use non-numeric string as operand of "|"} test mathop-7.12 {compiled |: errors} -returnCodes error -body { | nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "|"} + } -result {can't use non-numeric floating-point value as operand of "|"} test mathop-7.13 {compiled |: errors} -returnCodes error -body { | 0 x - } -result {can't use non-numeric string "x" as operand of "|"} + } -result {can't use non-numeric string as operand of "|"} test mathop-7.14 {compiled |: errors} -returnCodes error -body { | 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "|"} + } -result {can't use non-numeric floating-point value as operand of "|"} test mathop-7.15 {compiled |: errors} -returnCodes error -body { | 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "|"} + } -result {can't use invalid octal number as operand of "|"} test mathop-7.16 {compiled |: errors} -returnCodes error -body { | 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "|"} + } -result {can't use invalid octal number as operand of "|"} test mathop-7.17 {compiled |: errors} -returnCodes error -body { | 0 [error expectedError] } -result expectedError test mathop-7.18 {compiled |: argument processing order} -body { # Bytecode compilation known hard for 3+ arguments @@ -527,36 +527,36 @@ test mathop-7.20 {interpreted |} { $op 1 } 1 test mathop-7.21 {interpreted |} { $op 1 2 } 3 test mathop-7.22 {interpreted |} { $op 3 7 6 } 7 test mathop-7.23 {interpreted |} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "|"} + } -result {can't use floating-point value as operand of "|"} test mathop-7.24 {interpreted |} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "|"} + } -result {can't use floating-point value as operand of "|"} test mathop-7.25 {interpreted |} { $op 100000000002 18 -126 } -110 test mathop-7.26 {interpreted |} { $op 0xff 0o377 333333333333 } 333333333503 test mathop-7.27 {interpreted |} { $op 1000000000000000000002 18 -126 } -110 test mathop-7.28 {interpreted |} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333503 test mathop-7.29 {interpreted |: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string "x" as operand of "|"} + } -result {can't use non-numeric string as operand of "|"} test mathop-7.30 {interpreted |: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "|"} + } -result {can't use non-numeric floating-point value as operand of "|"} test mathop-7.31 {interpreted |: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string "x" as operand of "|"} + } -result {can't use non-numeric string as operand of "|"} test mathop-7.32 {interpreted |: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "|"} + } -result {can't use non-numeric floating-point value as operand of "|"} test mathop-7.33 {interpreted |: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "|"} + } -result {can't use invalid octal number as operand of "|"} test mathop-7.34 {interpreted |: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "|"} + } -result {can't use invalid octal number as operand of "|"} test mathop-7.35 {interpreted |: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError test mathop-7.36 {interpreted |: argument processing order} -body { list [catch { @@ -595,36 +595,36 @@ test mathop-8.2 {compiled ^} { ^ 1 } 1 test mathop-8.3 {compiled ^} { ^ 1 2 } 3 test mathop-8.4 {compiled ^} { ^ 3 7 6 } 2 test mathop-8.5 {compiled ^} -returnCodes error -body { ^ 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "^"} + } -result {can't use floating-point value as operand of "^"} test mathop-8.6 {compiled ^} -returnCodes error -body { ^ 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "^"} + } -result {can't use floating-point value as operand of "^"} test mathop-8.7 {compiled ^} { ^ 100000000002 18 -126 } -100000000110 test mathop-8.8 {compiled ^} { ^ 0xff 0o377 333333333333 } 333333333333 test mathop-8.9 {compiled ^} { ^ 1000000000000000000002 18 -126 } -1000000000000000000110 test mathop-8.10 {compiled ^} { ^ 0xff 0o377 3333333333333333333333 } 3333333333333333333333 test mathop-8.11 {compiled ^: errors} -returnCodes error -body { ^ x 0 - } -result {can't use non-numeric string "x" as operand of "^"} + } -result {can't use non-numeric string as operand of "^"} test mathop-8.12 {compiled ^: errors} -returnCodes error -body { ^ nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "^"} + } -result {can't use non-numeric floating-point value as operand of "^"} test mathop-8.13 {compiled ^: errors} -returnCodes error -body { ^ 0 x - } -result {can't use non-numeric string "x" as operand of "^"} + } -result {can't use non-numeric string as operand of "^"} test mathop-8.14 {compiled ^: errors} -returnCodes error -body { ^ 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "^"} + } -result {can't use non-numeric floating-point value as operand of "^"} test mathop-8.15 {compiled ^: errors} -returnCodes error -body { ^ 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "^"} + } -result {can't use invalid octal number as operand of "^"} test mathop-8.16 {compiled ^: errors} -returnCodes error -body { ^ 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "^"} + } -result {can't use invalid octal number as operand of "^"} test mathop-8.17 {compiled ^: errors} -returnCodes error -body { ^ 0 [error expectedError] } -result expectedError test mathop-8.18 {compiled ^: argument processing order} -body { # Bytecode compilation known hard for 3+ arguments @@ -637,36 +637,36 @@ test mathop-8.20 {interpreted ^} { $op 1 } 1 test mathop-8.21 {interpreted ^} { $op 1 2 } 3 test mathop-8.22 {interpreted ^} { $op 3 7 6 } 2 test mathop-8.23 {interpreted ^} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value "1.0" as operand of "^"} + } -result {can't use floating-point value as operand of "^"} test mathop-8.24 {interpreted ^} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value "3.0" as operand of "^"} + } -result {can't use floating-point value as operand of "^"} test mathop-8.25 {interpreted ^} { $op 100000000002 18 -126 } -100000000110 test mathop-8.26 {interpreted ^} { $op 0xff 0o377 333333333333 } 333333333333 test mathop-8.27 {interpreted ^} { $op 1000000000000000000002 18 -126 } -1000000000000000000110 test mathop-8.28 {interpreted ^} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333333 test mathop-8.29 {interpreted ^: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string "x" as operand of "^"} + } -result {can't use non-numeric string as operand of "^"} test mathop-8.30 {interpreted ^: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value "nan" as operand of "^"} + } -result {can't use non-numeric floating-point value as operand of "^"} test mathop-8.31 {interpreted ^: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string "x" as operand of "^"} + } -result {can't use non-numeric string as operand of "^"} test mathop-8.32 {interpreted ^: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value "nan" as operand of "^"} + } -result {can't use non-numeric floating-point value as operand of "^"} test mathop-8.33 {interpreted ^: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use non-numeric string "0o8" as operand of "^"} + } -result {can't use invalid octal number as operand of "^"} test mathop-8.34 {interpreted ^: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use non-numeric string "0o8" as operand of "^"} + } -result {can't use invalid octal number as operand of "^"} test mathop-8.35 {interpreted ^: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError test mathop-8.36 {interpreted ^: argument processing order} -body { list [catch { @@ -773,17 +773,17 @@ set exp {} foreach vals {x {1 x} {1 1 x} {1 x 1}} { # skipping - for now, knownbug... foreach op {+ * / & | ^ **} { lappend res [TestOp $op {*}$vals] - lappend exp "can't use non-numeric string \"x\" as operand of \"$op\"\ + lappend exp "can't use non-numeric string as operand of \"$op\"\ ARITH DOMAIN {non-numeric string}" } } foreach op {+ * / & | ^ **} { lappend res [TestOp $op NaN 1] - lappend exp "can't use non-numeric floating-point value \"NaN\" as operand of \"$op\"\ + lappend exp "can't use non-numeric floating-point value as operand of \"$op\"\ ARITH DOMAIN {non-numeric floating-point value}" } expr {$res eq $exp ? 0 : $res} } 0 test mathop-20.7 { multi arg } { @@ -848,19 +848,19 @@ 2.8196218755553604e-15 8.10000006561e-27] test mathop-21.5 { unary ops, bad values } { set res {} set exp {} lappend res [TestOp / x] - lappend exp "can't use non-numeric string \"x\" as operand of \"/\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"/\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp - x] - lappend exp "can't use non-numeric string \"x\" as operand of \"-\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"-\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ x] - lappend exp "can't use non-numeric string \"x\" as operand of \"~\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"~\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ! x] - lappend exp "can't use non-numeric string \"x\" as operand of \"!\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"!\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ 5.0] - lappend exp "can't use floating-point value \"5.0\" as operand of \"~\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value as operand of \"~\" ARITH DOMAIN {floating-point value}" expr {$res eq $exp ? 0 : $res} } 0 test mathop-21.6 { unary ops, too many } { set exp {} foreach op {~ !} { @@ -963,13 +963,13 @@ test mathop-22.4 { unary ops, bad values } { set res {} set exp {} foreach op {& | ^} { lappend res [TestOp $op x 5] - lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 5 x] - lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } expr {$res eq $exp ? 0 : $res} } 0 test mathop-23.1 { comparison ops, numerical } { @@ -1078,19 +1078,19 @@ test mathop-24.3 { binary ops, bad values } { set res {} set exp {} foreach op {% << >>} { lappend res [TestOp $op x 1] - lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 1 x] - lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } foreach op {% << >>} { lappend res [TestOp $op 5.0 1] - lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" lappend res [TestOp $op 1 5.0] - lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" } foreach op {in ni} { lappend res [TestOp $op 5 "a b \{ c"] lappend exp "unmatched open brace in list TCL VALUE LIST BRACE" } @@ -1238,13 +1238,13 @@ lappend res [TestOp ** 2 $big] lappend exp "exponent too large NONE" lappend res [TestOp ** $huge 2.1] lappend exp "Inf" lappend res [TestOp ** 2 foo] - lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ** foo 2] - lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" expr {$res eq $exp ? 0 : $res} } 0 test mathop-26.1 { misc ops, size combinations } { Index: tests/namespace-old.test ================================================================== --- tests/namespace-old.test +++ tests/namespace-old.test @@ -291,17 +291,16 @@ namespace eval test_ns_hier3b {} } namespace eval test_ns_hier2a {} namespace eval test_ns_hier2b {} } -# TIP 278: secondary lookup disabled for vars, tests disabled with # test namespace-old-5.4 {nested namespaces can access global namespace} { - list [namespace eval test_ns_hier1 {#set test_ns_var_global}] \ + list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ - [namespace eval test_ns_hier1::test_ns_hier2 {#set test_ns_var_global}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \ [namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}] -} {{} {cmd in ::} {} {cmd in ::}} +} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}} test namespace-old-5.5 {variables in different namespaces don't conflict} { list [set test_ns_hier1::test_ns_level] \ [set test_ns_hier1::test_ns_hier2::test_ns_level] } {1 2} test namespace-old-5.6 {commands in different namespaces don't conflict} { @@ -467,42 +466,39 @@ proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} { return "cache2 version" } list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] } {{cache2 version} {cache2 version}} -# TIP 278: secondary lookup disabled, catch added, result changed from {global version} test namespace-old-6.12 {define test variables} { variable test_ns_cache_var "global version" set trigger {set test_ns_cache_var} - list [catch {namespace eval test_ns_cache1 $trigger} msg] $msg -} {1 {can't read "test_ns_cache_var": no such variable}} + namespace eval test_ns_cache1 $trigger +} {global version} set trigger {set test_ns_cache_var} test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } namespace eval test_ns_cache1 $trigger } {cache1 version} variable ::test_ns_cache_var "global version" -# TIP 278: secondary lookup disabled, catch added, result changed from {global version} test namespace-old-6.14 {deleting variables changes variable epoch} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 {unset test_ns_cache_var}] \ - [catch {namespace eval test_ns_cache1 $trigger}] -} {{cache1 version} {} 1} -# TIP 278: secondary lookup disabled, catch added, result changed + [namespace eval test_ns_cache1 $trigger] +} {{cache1 version} {} {global version}} test namespace-old-6.15 {define test namespaces} { namespace eval test_ns_cache2 { variable test_ns_cache_var "global cache2 version" } set trigger2 {set test_ns_cache2::test_ns_cache_var} - catch {list [namespace eval test_ns_cache1 $trigger2] \ - [namespace eval test_ns_cache1::test_ns_cache2 $trigger]} -} 1 + list [namespace eval test_ns_cache1 $trigger2] \ + [namespace eval test_ns_cache1::test_ns_cache2 $trigger] +} {{global cache2 version} {global version}} set trigger2 {set test_ns_cache2::test_ns_cache_var} test namespace-old-6.16 {public variables affect all parent namespaces} { variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" list [namespace eval test_ns_cache1 $trigger2] \ [namespace eval test_ns_cache1::test_ns_cache2 $trigger] Index: tests/namespace.test ================================================================== --- tests/namespace.test +++ tests/namespace.test @@ -44,13 +44,13 @@ } {:: :: ::} test namespace-2.2 {Tcl_GetCurrentNamespace} { set l {} lappend l [namespace current] namespace eval test_ns_1 { - lappend ::l [namespace current] + lappend l [namespace current] namespace eval foo { - lappend ::l [namespace current] + lappend l [namespace current] } } lappend l [namespace current] } {:: ::test_ns_1 ::test_ns_1::foo ::} @@ -193,10 +193,23 @@ slave eval foo slave invokehidden infocommands } -cleanup { interp delete slave } -result {} + +test namespace-7.8 {Bug ba1419303b4c} -setup { + namespace eval ns1 { + namespace ensemble create + } + + trace add command ns1 delete { + namespace delete ns1 + } +} -body { + # No segmentation fault given --enable-symbols=mem. + namespace delete ns1 +} -result {} test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { @@ -631,12 +644,10 @@ namespace eval test_ns_1 { list [catch {set ::test_ns_777::v} msg] $msg \ [catch {namespace children test_ns_777} msg] $msg } } -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} - -# TIP 278: secondary lookup disabled, results changed from {10 20} test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} variable v 10 namespace eval test_ns_1::test_ns_2 { variable v 20 @@ -644,15 +655,13 @@ namespace eval test_ns_2 { variable v 30 } } -body { namespace eval test_ns_1 { - # list $v $test_ns_2::v - list [catch {set v} msg] $msg [catch {set test_ns_2::v} msg] $msg + list $v $test_ns_2::v } -} -result {1 {can't read "v": no such variable} 0 20} - +} -result {10 20} test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { namespace eval foo {} } namespace eval test_ns_1 { @@ -709,21 +718,19 @@ } -body { lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} lappend l [test_ns_1::test_ns_2:: hello] } -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} - -# TIP 278: secondary lookup disabled, added catch, result changed from y test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -body { namespace eval test_ns_1 { variable {} - catch {set test_ns_1::(x) y} ::msg + set test_ns_1::(x) y } - list $::msg [catch {set test_ns_1::(x)} msg] $msg -} -result {{can't set "test_ns_1::(x)": parent namespace doesn't exist} 1 {can't read "test_ns_1::(x)": no such variable}} + set test_ns_1::(x) +} -result y test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -returnCodes error -body { namespace eval test_ns_1 { proc {} {} {} @@ -892,19 +899,17 @@ } -body { namespace eval test_ns_1 { set x } } -result {777} - -# TIP 278: secondary lookup disabled, catch added, result changed from 314159 test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { namespace eval test_ns_1 { variable x 777 unset x - list [catch {set x} msg] $msg ;# must not be global x now + set x ;# must be global x now } -} {1 {can't read "x": no such variable}} +} {314159} test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body { namespace eval test_ns_1 { set wuzzat } } -returnCodes error -result {can't read "wuzzat": no such variable} @@ -912,12 +917,10 @@ namespace eval test_ns_1 { variable a hello } set test_ns_1::a } {hello} - -# TIP 278: secondary lookup disabled, result changed from 1 test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup { namespace eval test_ns_1 {} } -body { proc test_ns {} { set ::test_ns_1::a 0 @@ -927,11 +930,11 @@ namespace eval test_ns_1 unset a set a 0 namespace eval test_ns_1 set a 1 namespace delete test_ns_1 return $a -} -result 0 +} -result 1 catch {unset a} catch {unset x} catch {unset l} catch {rename foo {}} @@ -1548,12 +1551,10 @@ [namespace which p] \ [namespace which cmd1] \ [namespace which ::test_ns_2::cmd2] } } -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} - -# TIP 278: secondary lookup disabled, catch added, result changed test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { namespace export cmd* proc cmd1 {args} {return "cmd1: $args"} @@ -1569,16 +1570,16 @@ variable v3 333 namespace import ::test_ns_2::* } } -body { namespace eval test_ns_3 { - list [catch {namespace which -variable env } msg] $msg \ + list [namespace which -variable env] \ [namespace which -variable v3] \ [namespace which -variable ::test_ns_2::v2] \ [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg } -} -result {0 {} ::test_ns_3::v3 ::test_ns_2::v2 0 {}} +} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -body { namespace eval test_ns_1 { @@ -1794,12 +1795,15 @@ namespace ensemble create } list [ns x0 z] [ns x1] [ns x2] [ns x3] } -cleanup { namespace delete ns -} -result {{1 ::ns::x0::z} 1 2 3} -test namespace-42.8 {ensembles: [Bug 1670091]} -setup { +} -result {{1 z} 1 2 3} +test namespace-42.8 { + ensembles: [Bug 1670091], panic due to pointer to a deallocated List + struct. +} -setup { proc demo args {} variable target [list [namespace which demo] x] proc trial args {variable target; string length $target} trace add execution demo enter [namespace code trial] namespace ensemble create -command foo -map [list bar $target] @@ -1810,10 +1814,38 @@ rename demo {} rename trial {} rename foo {} } -result {} +test namespace-42.9 { + ensembles: [Bug 4f6a1ebd64], segmentation fault due to pointer to a + deallocated List struct. +} -setup { + namespace eval n {namespace ensemble create} + set lst [dict create one ::two] + namespace ensemble configure n -subcommands $lst -map $lst +} -body { + n one +} -cleanup { + namespace delete n + unset -nocomplain lst +} -returnCodes error -match glob -result {invalid command name*} + +test namespace-42.10 { + ensembles: [Bug 4f6a1ebd64] segmentation fault due to pointer to a + deallocated List struct (this time with duplicate of one in "dict"). +} -setup { + namespace eval n {namespace ensemble create} + set lst [list one ::two one ::three] + namespace ensemble configure n -subcommands $lst -map $lst +} -body { + n one +} -cleanup { + namespace delete n + unset -nocomplain lst +} -returnCodes error -match glob -result {invalid command name *three*} + test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { namespace export x* proc x1 {} {format 1} proc x2 {} {format 2} @@ -1930,11 +1962,11 @@ namespace ensemble create -command foobar -subcommands {foobarcget foobarconfigure} } -body { foobar foobarcon } -cleanup { rename foobar {} -} -returnCodes error -result {invalid command name "::foobarconfigure"} +} -returnCodes error -result {invalid command name "foobarconfigure"} test namespace-44.6 {ensemble: errors} -returnCodes error -body { namespace ensemble create gorp } -result {wrong # args: should be "namespace ensemble create ?option value ...?"} test namespace-45.1 {ensemble: introspection} { @@ -2094,11 +2126,11 @@ lappend result [catch {ns a b c} msg] $msg lappend result [catch {ns b c d} msg] $msg lappend result [catch {ns c d e} msg] $msg lappend result [catch {ns Magic foo bar spong wibble} msg] $msg list $result [lsort [info commands ::ns::*]] $log [namespace delete ns] -} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ::ns::a b c} {running ::ns::a b c} {making b} {running ::ns::b c d} {making c} {running ::ns::c d e} {unknown Magic - args = foo bar spong wibble}} {}} +} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running a b c} {running a b c} {making b} {running b c d} {making c} {running c d e} {unknown Magic - args = foo bar spong wibble}} {}} test namespace-47.2 {ensemble: unknown handler} { namespace eval ns { namespace export {[a-z]*} proc Magic {ensemble subcmd args} { error foobar @@ -3193,11 +3225,11 @@ } -result\ {0 0\ 1 {wrong # args: should be "ns z1 x a1"}\ 1 {wrong # args: should be "ns z2 x a1 a2"}\ 1 {wrong # args: should be "ns z2 x a1 a2"}\ - 1 {wrong # args: should be "::ns::x::z0"}\ + 1 {wrong # args: should be "z0"}\ 0 {1 v}\ 1 {wrong # args: should be "ns v x z2 a2"}\ 0 {2 v v2}} test namespace-53.11 {ensembles: nested rewrite} -setup { namespace eval ns { @@ -3277,10 +3309,22 @@ } finally { namespace delete ::testing } } } {::testing::abc::def ::testing::abc::ghi} + +test namespace-56.4 {bug 16fe1b5807: names starting with ":"} { +namespace eval : { + namespace ensemble create + namespace export * + proc p1 {} { + return 16fe1b5807 + } +} + +: p1 +} 16fe1b5807 # cleanup catch {rename cmd1 {}} catch {unset l} catch {unset msg} Index: tests/oo.test ================================================================== --- tests/oo.test +++ tests/oo.test @@ -45,11 +45,11 @@ } interp delete $i } {} 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 { leaktest { oo::class create foo @@ -126,10 +126,17 @@ while executing \"oo::define oo::object method missingArgs\"" test oo-1.4 {basic test of OO functionality} -body { oo::object create {} } -returnCodes 1 -result {object name must not be empty} +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} test oo-1.5.1 {basic test of OO functionality} -setup { oo::object create aninstance @@ -1496,24 +1503,26 @@ } done test oo-11.6 { OO: cleanup ReleaseClassContents() where class is mixed into one of its instances -} { +} -body { oo::class create obj1 ::oo::define obj1 {self mixin [self]} ::oo::copy obj1 obj2 ::oo::objdefine obj2 {mixin [self]} ::oo::copy obj2 obj3 - trace add command obj3 delete [list obj3 dying] + rename obj3 {} rename obj2 {} # No segmentation fault return done -} done +} -result done -cleanup { + rename obj1 {} +} test oo-12.1 {OO: filters} { oo::class create Aclass Aclass create Aobject oo::define Aclass { @@ -3862,10 +3871,32 @@ E create e1 list [lsort [info class methods E -all]] [lsort [info object methods e1 -all]] } -cleanup { base destroy } -result {{c d e} {c d e}} +test oo-35.6 { + Bug : teardown of an object that is a class that is an instance of itself +} -setup { + oo::class create obj + + oo::copy obj obj1 obj1 + oo::objdefine obj1 { + mixin obj1 obj + } + oo::copy obj1 obj2 + oo::objdefine obj2 { + mixin obj2 obj1 + } +} -body { + rename obj2 {} + rename obj1 {} + # doesn't crash + return done +} -cleanup { + rename obj {} +} -result done + test oo-36.1 {TIP #470: introspection within oo::define} { oo::define oo::object self } ::oo::object test oo-36.2 {TIP #470: introspection within oo::define} -setup { oo::class create Cls Index: tests/package.test ================================================================== --- tests/package.test +++ tests/package.test @@ -18,22 +18,23 @@ } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -testConstraint testpreferstable [llength [info commands testpreferstable]] - # Do all this in a slave interp to avoid garbaging the package list set i [interp create] tcltest::loadIntoSlaveInterpreter $i {*}$argv +load {} Tcltest $i interp eval $i { namespace import -force ::tcltest::* -package forget {*}[package names] +#package forget {*}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path set auto_path "" + +testConstraint testpreferstable [llength [info commands testpreferstable]] test package-1.1 {pkg::create gives error on insufficient args} -body { ::pkg::create } -returnCodes error -match glob -result {wrong # args: should be "*"} test package-1.2 {pkg::create gives error on bad args} -body { @@ -137,51 +138,51 @@ } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.4} test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.5} test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {3.5 2.1 2.3} { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.2 - return $x + set x } -result {2.3} test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require -exact t 2.3 - return $x + set x } -result {2.3} test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t set x xxx } -body { foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.1 - return $x + set x } -result {2.4} test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { package forget t } -returnCodes error -body { package unknown {} @@ -236,11 +237,11 @@ package forget t set x xxx } -body { package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" package require t 1.2 - return $x + set x } -result {1.2} test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t set x xxx } -body { @@ -254,11 +255,11 @@ foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i" } package unknown pkgUnknown package require -exact t 1.5 - return $x + set x } -cleanup { package unknown {} } -result {t 1.5-1.5} test package-3.14 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t @@ -281,11 +282,11 @@ global x set x $args package provide [lindex $args 0] 2.0 } package require {a b} - return $x + set x } -cleanup { package unknown {} } -result {{a b} 0-} test package-3.16 {Tcl_PkgRequire procedure, "package unknown" error} -setup { package forget t @@ -573,73 +574,119 @@ package require -exact demo 1.2 } -returnCodes error -cleanup { package forget demo } -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + interp create child + load {} Tcltest child + child eval { testpreferstable package forget t set x xxx + } } -body { + child eval { foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x + } +} -cleanup { + interp delete child } -result {3.4} test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t set x xxx } -body { foreach i {1.2b1 1.2 1.3a2 1.3} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t set x xxx } -body { foreach i {1.2b1 1.2 1.3 1.3a2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} +test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + testpreferstable + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.1} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + set x +} -result {1.1} + test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { package } -result {wrong # args: should be "package option ?arg ...?"} -test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} -test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + } +} -cleanup { + interp delete child +} -result {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package forget foo -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] set result {} + } } -body { + child eval { package ifneeded t 1.1 {first script} package ifneeded t 2.3 {second script} package ifneeded x 1.4 {x's script} lappend result [lsort [package names]] [package versions t] package forget t lappend result [lsort [package names]] [package versions t] + } +} -cleanup { + interp delete child } -result {{t x} {1.1 2.3} x {}} test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded a 1.1 {first script} package ifneeded b 2.3 {second script} package ifneeded c 1.4 {third script} package forget set result [list [lsort [package names]]] package forget a c lappend result [lsort [package names]] + } +} -cleanup { + interp delete child } -result {{a b c} b} test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { # Test for Bug 415273 package ifneeded a 1 "I should have been forgotten" package forget no-such-package a @@ -654,32 +701,59 @@ package ifneeded a b c d } -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { package ifneeded t xyz } -returnCodes error -result {expected version number but got "xyz"} -test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] list [package ifneeded foo 1.1] [package names] -} {{} {}} + } +} -cleanup { + interp delete child +} -result {{} {}} test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package names] [package ifneeded t 1.4] [package versions t] + } +} -cleanup { + interp delete child } -result {t {script for t 1.4} 1.4} test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package ifneeded t 1.5] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{} t 1.4} test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" package ifneeded t 1.4 "second script for t 1.4" list [package ifneeded t 1.4] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{second script for t 1.4} t 1.4} test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { package forget t } -body { package ifneeded t 1.4 "script for t 1.4" @@ -688,22 +762,35 @@ list [package ifneeded t 1.2] [package versions t] } -result {{second script} {1.4 1.2 3.1}} test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { package names a } -returnCodes error -result {wrong # args: should be "package names"} -test package-4.15 {Tcl_PackageCmd procedure, "names" option} { +test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded x 1.2 {dummy} package provide x 1.3 package provide y 2.4 catch {package require z 47.16} lsort [package names] + } +} -cleanup { + interp delete child } -result {x y} test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { package provide } -returnCodes error -result {wrong # args: should be "package provide package ?version?"} test package-4.18 {Tcl_PackageCmd procedure, "provide" option} -body { @@ -1237,15 +1324,13 @@ } finally { interp delete $ip } } -test package-13.0 {package prefer defaults} -constraints testpreferstable -setup { - testpreferstable -} -body { +test package-13.0 {package prefer defaults} -body { prefer -} -result stable +} -result [expr {[string match {*[ab]*} [package provide Tcl]] ? "latest" : "stable"}] test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer } -cleanup { unset -nocomplain ::env(TCL_PKG_PREFER_LATEST) @@ -1258,27 +1343,29 @@ package prefer foo } -result {bad preference "foo": must be latest or stable} test package-15.0 {set, keep} -constraints testpreferstable -setup { testpreferstable -} -body {package prefer stable} -result stable +} -body {package prefer} -result stable test package-15.1 {set stable, keep} -constraints testpreferstable -setup { testpreferstable -} -body {prefer stable} -result {stable stable} +} -body {package prefer stable} -result stable test package-15.2 {set latest, change} -constraints testpreferstable -setup { testpreferstable -} -body {prefer latest} -result {stable latest} +} -body {package prefer latest} -result latest test package-15.3 {set latest, keep} -constraints testpreferstable -setup { testpreferstable } -body { - prefer latest latest -} -result {stable latest latest} + package prefer latest + package prefer latest +} -result latest test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { testpreferstable } -body { - prefer latest stable -} -result {stable latest latest} + package prefer latest + package prefer stable +} -result latest rename prefer {} set auto_path $oldPath package unknown $oldPkgUnknown Index: tests/parse.test ================================================================== --- tests/parse.test +++ tests/parse.test @@ -374,16 +374,16 @@ set aresult $result set acode $code return "new result" } set handler1 [testasync create async1] - set ::aresult xxx - set ::acode yyy + set aresult xxx + set acode yyy } -cleanup { testasync delete } -body { - list [testevalobjv 0 testasync mark $handler1 original 0] $::acode $::aresult + list [testevalobjv 0 testasync mark $handler1 original 0] $acode $aresult } -result {{new result} 0 original} test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv { list [catch {testevalobjv 0 error message} msg] $msg } {1 message} test parse-8.10 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL} testevalobjv { Index: tests/result.test ================================================================== --- tests/result.test +++ tests/result.test @@ -29,11 +29,11 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult append {set x 42} 0 } {append result} test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 0 -} {dynamic result freed} +} {dynamic result presentOrFreed} test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 0 } {object result same} test result-1.5 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult small {set x 42} 1 @@ -41,11 +41,11 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult append {set x 42} 1 } {42} test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 1 -} {42 freed} +} {42 presentOrFreed} test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 1 } {42 different} # Tcl_RestoreInterpResult is mostly tested by the previous tests except Index: tests/safe.test ================================================================== --- tests/safe.test +++ tests/safe.test @@ -72,11 +72,11 @@ } -body { interp create a -safe lsort [a aliases] } -cleanup { interp delete a -} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock} +} -result {clock} test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} interp create a -safe } -body { @@ -178,21 +178,21 @@ # More test should be added to check that hostname, nameofexecutable, aren't # 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) set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p1 Index: tests/scan.test ================================================================== --- tests/scan.test +++ tests/scan.test @@ -551,11 +551,11 @@ set a {}; } -body { list [scan "-207698809136909011942886895" \ %llu a] $a } -returnCodes 1 -result {unsigned bignum scans are invalid} -test scan-5.18 {bigint scanning invalid} -setup { +test scan-5.19 {bigint scanning invalid} -setup { set a {}; } -body { list [scan "207698809136909011942886895" \ %llu a] $a } -returnCodes 1 -result {unsigned bignum scans are invalid} Index: tests/split.test ================================================================== --- tests/split.test +++ tests/split.test @@ -68,10 +68,13 @@ split "12,34,56," {,} } {12 34 56 {}} test split-1.14 {basic split commands} { split ",12,,,34,56," {,} } {{} 12 {} {} 34 56 {}} +test split-1.15 {basic split commands} -body { + split "a\U01f4a9b" {} +} -result "a \U01f4a9 b" test split-2.1 {split errors} { list [catch split msg] $msg $errorCode } {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}} test split-2.2 {split errors} { Index: tests/string.test ================================================================== --- tests/string.test +++ tests/string.test @@ -22,10 +22,11 @@ # Some tests require the testobj command 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]] proc representationpoke s { @@ -290,14 +291,14 @@ binary scan $str H* dump string compare [string index $str 10] \x00 } 0 test string-5.17 {string index, bad integer} -body { list [catch {string index "abc" 0o8} msg] $msg -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test string-5.18 {string index, bad integer} -body { list [catch {string index "abc" end-0o0289} msg] $msg -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test string-5.19 {string index, bytearray object out of bounds} { string index [binary format I* {0x50515253 0x52}] -1 } {} test string-5.20 {string index, bytearray object out of bounds} { string index [binary format I* {0x50515253 0x52}] 20 @@ -1286,10 +1287,13 @@ test string-12.22 {string range, shimmering binary/index} { set s 0000000001 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 } {1 {wrong # args: should be "string repeat string count"}} test string-13.2 {string repeat} { Index: tests/stringComp.test ================================================================== --- tests/stringComp.test +++ tests/stringComp.test @@ -353,15 +353,15 @@ foo } 0 test stringComp-5.17 {string index, bad integer} -body { proc foo {} {string index "abc" 0o8} list [catch {foo} msg] $msg -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test stringComp-5.18 {string index, bad integer} -body { proc foo {} {string index "abc" end-0o0289} list [catch {foo} msg] $msg -} -match glob -result {1 {*}} +} -match glob -result {1 {*invalid octal number*}} test stringComp-5.19 {string index, bytearray object out of bounds} { proc foo {} {string index [binary format I* {0x50515253 0x52}] -1} foo } {} test stringComp-5.20 {string index, bytearray object out of bounds} { Index: tests/tcltest.test ================================================================== --- tests/tcltest.test +++ tests/tcltest.test @@ -542,11 +542,10 @@ # Test non-writeable directories, non-readable directories with directory flags set notReadableDir [file join [temporaryDirectory] notreadable] set notWriteableDir [file join [temporaryDirectory] notwriteable] makeDirectory notreadable makeDirectory notwriteable - switch -- $::tcl_platform(platform) { unix { file attributes $notReadableDir -permissions 00333 file attributes $notWriteableDir -permissions 00555 } Index: tests/utf.test ================================================================== --- tests/utf.test +++ tests/utf.test @@ -84,10 +84,13 @@ test utf-3.1 {Tcl_UtfCharComplete} { } {} testConstraint testnumutfchars [llength [info commands testnumutfchars]] +testConstraint testfindfirst [llength [info commands testfindfirst]] +testConstraint testfindlast [llength [info commands testfindlast]] + test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars { testnumutfchars "" } {0} test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xC2\xA2"] @@ -116,12 +119,16 @@ } {2} test utf-4.10 {Tcl_NumUtfChars: #u0000, calc len, overcomplete} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\x00"] 2 } {2} -test utf-5.1 {Tcl_UtfFindFirsts} { -} {} +test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} { + testfindfirst [testbytestring "abcbc"] 98 +} {bcbc} +test utf-5.2 {Tcl_UtfFindLast} {testfindlast testbytestring} { + testfindlast [testbytestring "abcbc"] 98 +} {bc} test utf-6.1 {Tcl_UtfNext} { } {} test utf-7.1 {Tcl_UtfPrev} { Index: tests/var.test ================================================================== --- tests/var.test +++ tests/var.test @@ -245,15 +245,14 @@ set a 456 namespace eval test_ns_var { catch {unset ::test_ns_var::vv} proc p {} { # create namespace var vv linked to global a - testupvar 2 a {} vv namespace + testupvar 1 a {} vv namespace } p } - # Modified: that should create a global var according to the docs! list $test_ns_var::vv [set test_ns_var::vv 123] $a } -result {456 123 123} test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { catch {unset aaaaa} catch {unset xxxxx} @@ -441,11 +440,11 @@ set a "" set five 555 set six 666 namespace eval test_ns_var { variable five 5 six - lappend ::a $five + lappend a $five } lappend a $test_ns_var::five \ [set test_ns_var::six 6] [set test_ns_var::six] $six } -cleanup { catch {unset five} @@ -468,13 +467,13 @@ } -result {can't define "sev:::en": parent namespace doesn't exist} test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} { set a "" namespace eval test_ns_var { variable eight 8 - lappend ::a $eight + lappend a $eight variable eight - lappend ::a $eight + lappend a $eight } set a } {8 8} test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup { catch {namespace delete test_ns_var2} Index: tests/while-old.test ================================================================== --- tests/while-old.test +++ tests/while-old.test @@ -90,11 +90,11 @@ list $err $msg } {1 {wrong # args: should be "while test command"}} test while-old-4.4 {errors in while loops} { set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] list $err $msg -} {1 {can't use non-numeric string "a" as operand of "+"}} +} {1 {can't use non-numeric string as operand of "+"}} test while-old-4.5 {errors in while loops} { catch {unset x} set x 1 set err [catch {while {$x} {set x foo}} msg] list $err $msg Index: tests/while.test ================================================================== --- tests/while.test +++ tests/while.test @@ -30,11 +30,11 @@ } -cleanup { unset i } -match glob -result {*"while {$i<} break"} test while-1.3 {TclCompileWhileCmd: error in test expression} -body { while {"a"+"b"} {error "loop aborted"} -} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"} +} -returnCodes error -result {can't use non-numeric string as operand of "+"} test while-1.4 {TclCompileWhileCmd: multiline test expr} -body { set value 1 while {($tcl_platform(platform) != "foobar1") && \ ($tcl_platform(platform) != "foobar2")} { incr value @@ -341,11 +341,11 @@ unset i z } -result {*"$z {$i<} {set x 1}"} test while-4.4 {while (not compiled): error in test expression} -body { set z while $z {"a"+"b"} {error "loop aborted"} -} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"} +} -returnCodes error -result {can't use non-numeric string as operand of "+"} test while-4.5 {while (not compiled): multiline test expr} -body { set value 1 set z while $z {($tcl_platform(platform) != "foobar1") && \ ($tcl_platform(platform) != "foobar2")} { Index: tools/README ================================================================== --- tools/README +++ tools/README @@ -10,11 +10,11 @@ Generating HTML files. The tcl-tk-man-html.tcl script from Robert Critchlow generates a nice set of HTML with good cross references. Use it like - tclsh tcl-tk-man-html.tcl --htmldir=/tmp/tcl9.0 + tclsh tcl-tk-man-html.tcl --htmldir=/tmp/tcl8.2 This script is very picky about the organization of man pages, effectively acting as a style enforcer. Generating Windows Help Files: 1) Build tcl in the ../unix directory Index: tools/checkLibraryDoc.tcl ================================================================== --- tools/checkLibraryDoc.tcl +++ tools/checkLibraryDoc.tcl @@ -1,11 +1,11 @@ # checkLibraryDoc.tcl -- # # This script attempts to determine what APIs exist in the source base that # have not been documented. By grepping through all of the doc/*.3 man # pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list -# against the list of Pkg_ APIs found in the source (e.g., tcl9.0/*/*.[ch]) +# against the list of Pkg_ APIs found in the source (e.g., tcl8.2/*/*.[ch]) # we create six lists: # 1) APIs in Source not in Docs. # 2) APIs in Docs not in Source. # 3) Internal APIs and structs. # 4) Misc APIs and structs that we are not documenting. @@ -104,11 +104,11 @@ set len [llength $argv] if {($len != 2) && ($len != 3)} { puts "usage: $argv0 pkgName pkgDir \[outFile\]" puts " pkgName == Tcl,Tk" - puts " pkgDir == /home/surles/cvs/tcl9.0" + puts " pkgDir == /home/surles/cvs/tcl8.2" exit 1 } set pkg [lindex $argv 0] set dir [lindex $argv 1] Index: tools/configure ================================================================== --- tools/configure +++ tools/configure @@ -1679,11 +1679,11 @@ #-------------------------------------------------------------------- # See if there was a command-line option for where Tcl is; if # not, assume that its top-level directory is a sibling of ours. #-------------------------------------------------------------------- -DEF_VER=9.0 +DEF_VER=8.7 # Check whether --with-tcl was given. if test "${with_tcl+set}" = set; then : withval=$with_tcl; TCL_BIN_DIR=$withval Index: tools/configure.ac ================================================================== --- tools/configure.ac +++ tools/configure.ac @@ -9,11 +9,11 @@ #-------------------------------------------------------------------- # See if there was a command-line option for where Tcl is; if # not, assume that its top-level directory is a sibling of ours. #-------------------------------------------------------------------- -DEF_VER=9.0 +DEF_VER=8.7 AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl $DEF_VER binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`) if test ! -d $TCL_BIN_DIR; then AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR doesn't exist) fi Index: tools/tcl.hpj.in ================================================================== --- tools/tcl.hpj.in +++ tools/tcl.hpj.in @@ -3,13 +3,13 @@ [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual -CNT=tcl90.cnt +CNT=tcl87.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl90.hlp +HLP=tcl87.hlp [FILES] tcl.rtf [WINDOWS] Index: tools/tcltk-man2html.tcl ================================================================== --- tools/tcltk-man2html.tcl +++ tools/tcltk-man2html.tcl @@ -2,11 +2,11 @@ if {[catch {package require Tcl 8.6-} msg]} { puts stderr "ERROR: $msg" puts stderr "If running this script from 'make html', set the\ NATIVE_TCLSH environment\nvariable to point to an installed\ - tclsh9.0 (or the equivalent tclsh90.exe\non Windows)." + tclsh8.7 (or the equivalent tclsh87.exe\non Windows)." exit 1 } # Convert Ousterhout format man pages into highly crosslinked hypertext. # @@ -20,11 +20,11 @@ # try to use this, you'll be very much on your own. # # Copyright (c) 1995-1997 Roger E. Critchlow Jr # Copyright (c) 2004-2010 Donal K. Fellows -set ::Version "50/9.0" +set ::Version "50/8.7" set ::CSSFILE "docs.css" ## ## Source the utility functions that provide most of the ## implementation of the transformation from nroff to html. Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -827,11 +827,11 @@ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; - @for i in opt0.4 http1.0 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform; \ + @for i in opt0.4 http1.0 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \ do \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ else true; \ @@ -847,25 +847,25 @@ @for i in $(TOP_DIR)/library/http1.0/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; @echo "Installing package http 2.8.12 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/http-2.8.12.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.12.tm; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/msgcat-1.6.1.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm; @echo "Installing package tcltest 2.4.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/tcltest-2.4.1.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/platform-1.0.14.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/platform/shell-1.1.4.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/encoding; \ done; @@ -2048,13 +2048,11 @@ $(TOP_DIR)/win/tclsh.exe.manifest.in \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win - cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win - cp -p $(TOP_DIR)/win/rules.vc $(DISTDIR)/win - cp -p $(TOP_DIR)/win/coffbase.txt $(DISTDIR)/win + cp -p $(TOP_DIR)/win/*.vc $(DISTDIR)/win cp -p $(TOP_DIR)/win/tcl.hpj.in $(DISTDIR)/win cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win cp -p $(TOP_DIR)/win/README $(DISTDIR)/win cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win @mkdir $(DISTDIR)/macosx @@ -2095,11 +2093,11 @@ gzip -9 $(DISTNAME)-src.tar; zip -qr8 $(ZIPNAME) $(DISTNAME) #-------------------------------------------------------------------------- # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool -# workspace. It depends on the Tcl & Tk being in directories called tcl9.* & +# workspace. It depends on the Tcl & Tk being in directories called tcl8.* & # tk8.* up two directories from the TOOL_DIR. # # Note that for platforms where this is important, it is more common to use a # build of this HTML documentation that has already been placed online. As # such, this rule is not guaranteed to work well on all systems; it only needs Index: unix/configure ================================================================== --- unix/configure +++ unix/configure @@ -1,8 +1,8 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for tcl 9.0. +# Generated by GNU Autoconf 2.69 for tcl 8.7. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # @@ -575,12 +575,12 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' -PACKAGE_VERSION='9.0' -PACKAGE_STRING='tcl 9.0' +PACKAGE_VERSION='8.7' +PACKAGE_STRING='tcl 8.7' PACKAGE_BUGREPORT='' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ @@ -1317,11 +1317,11 @@ # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures tcl 9.0 to adapt to many kinds of systems. +\`configure' configures tcl 8.7 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. @@ -1378,11 +1378,11 @@ _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tcl 9.0:";; + short | recursive ) echo "Configuration of tcl 8.7:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options @@ -1492,11 +1492,11 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -tcl configure 9.0 +tcl configure 8.7 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. @@ -1968,11 +1968,11 @@ } # ac_fn_c_check_member cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by tcl $as_me 9.0, which was +It was created by tcl $as_me 8.7, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF @@ -2320,14 +2320,14 @@ -TCL_VERSION=9.0 -TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a0" +TCL_VERSION=8.7 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=7 +TCL_PATCH_LEVEL="a2" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} @@ -3730,30 +3730,10 @@ if test $tcl_cv_dirent_h = no; then $as_echo "#define NO_DIRENT_H 1" >>confdefs.h fi - - ac_fn_c_check_header_mongrel "$LINENO" "float.h" "ac_cv_header_float_h" "$ac_includes_default" -if test "x$ac_cv_header_float_h" = xyes; then : - -else - -$as_echo "#define NO_FLOAT_H 1" >>confdefs.h - -fi - - - ac_fn_c_check_header_mongrel "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default" -if test "x$ac_cv_header_values_h" = xyes; then : - -else - -$as_echo "#define NO_VALUES_H 1" >>confdefs.h - -fi - ac_fn_c_check_header_mongrel "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default" if test "x$ac_cv_header_stdlib_h" = xyes; then : tcl_ok=1 else @@ -5317,11 +5297,11 @@ ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-lroot" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lnetwork" >&5 $as_echo_n "checking for inet_ntoa in -lnetwork... " >&6; } if ${ac_cv_lib_network_inet_ntoa+:} false; then : @@ -5639,11 +5619,11 @@ # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings # when you inline the string and math operations. Turn this off to # get rid of the warnings. #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" if test $doRpath = yes; then : @@ -5726,11 +5706,11 @@ ;; *) SHLIB_CFLAGS="-fpic" ;; esac - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" if test $doRpath = yes; then : @@ -5753,11 +5733,11 @@ TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" if test $doRpath = yes; then : @@ -10964,11 +10944,11 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by tcl $as_me 9.0, which was +This file was extended by tcl $as_me 8.7, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS @@ -11021,11 +11001,11 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -tcl config.status 9.0 +tcl config.status 8.7 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation Index: unix/configure.ac ================================================================== --- unix/configure.ac +++ unix/configure.ac @@ -1,11 +1,11 @@ #! /bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. -AC_INIT([tcl],[9.0]) +AC_INIT([tcl],[8.7]) AC_PREREQ(2.69) dnl This is only used when included from macosx/configure.ac m4_ifdef([SC_USE_CONFIG_HEADERS], [ AC_CONFIG_HEADERS([tclConfig.h:../unix/tclConfig.h.in]) @@ -20,14 +20,14 @@ /* override */ #undef PACKAGE_STRING /* override */ #undef PACKAGE_TARNAME #endif /* _TCLCONFIG */]) ]) -TCL_VERSION=9.0 -TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a0" +TCL_VERSION=8.7 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=7 +TCL_PATCH_LEVEL="a2" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} Index: unix/tcl.m4 ================================================================== --- unix/tcl.m4 +++ unix/tcl.m4 @@ -1248,11 +1248,11 @@ ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-lroot" AC_CHECK_LIB(network, inet_ntoa, [LIBS="$LIBS -lnetwork"]) ;; HP-UX-*.11.*) @@ -1392,11 +1392,11 @@ # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings # when you inline the string and math operations. Turn this off to # get rid of the warnings. #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) @@ -1442,11 +1442,11 @@ ;; *) SHLIB_CFLAGS="-fpic" ;; esac - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) @@ -1465,11 +1465,11 @@ TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" AS_IF([test $doRpath = yes], [ @@ -2038,11 +2038,10 @@ # # Results: # # Defines some of the following vars: # NO_DIRENT_H -# NO_VALUES_H # NO_STDLIB_H # NO_STRING_H # NO_SYS_WAIT_H # NO_DLFCN_H # HAVE_SYS_PARAM_H @@ -2076,12 +2075,10 @@ if test $tcl_cv_dirent_h = no; then AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?]) fi - AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have ?])]) - AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])]) AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) if test $tcl_ok = 0; then Index: unix/tcl.spec ================================================================== --- unix/tcl.spec +++ unix/tcl.spec @@ -2,11 +2,11 @@ %{!?directory:%define directory /usr/local} Name: tcl Summary: Tcl scripting language development environment -Version: 9.0a0 +Version: 8.7a2 Release: 2 License: BSD Group: Development/Languages Source: http://prdownloads.sourceforge.net/tcl/tcl%{version}-src.tar.gz URL: http://www.tcl.tk/ Index: unix/tclConfig.h.in ================================================================== --- unix/tclConfig.h.in +++ unix/tclConfig.h.in @@ -293,13 +293,10 @@ #undef NO_DLFCN_H /* Do we have fd_set? */ #undef NO_FD_SET -/* Do we have ? */ -#undef NO_FLOAT_H - /* Do we have fstatfs()? */ #undef NO_FSTATFS /* Do we have gettimeofday()? */ #undef NO_GETTOD @@ -332,13 +329,10 @@ #undef NO_UNAME /* Do we have a usable 'union wait'? */ #undef NO_UNION_WAIT -/* Do we have ? */ -#undef NO_VALUES_H - /* Do we have wait3() */ #undef NO_WAIT3 /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT Index: unix/tclUnixInit.c ================================================================== --- unix/tclUnixInit.c +++ unix/tclUnixInit.c @@ -37,15 +37,10 @@ DLLIMPORT extern __stdcall void *GetModuleHandleW(const void *); DLLIMPORT extern __stdcall void FreeLibrary(void *); DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *); DLLIMPORT extern __stdcall void GetSystemInfo(void *); -#define NUMPLATFORMS 4 -static const char *const platforms[NUMPLATFORMS] = { - "Win32s", "Windows 95", "Windows NT", "Windows CE" -}; - #define NUMPROCESSORS 11 static const char *const processors[NUMPROCESSORS] = { "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" }; @@ -451,11 +446,11 @@ */ void TclpInitLibraryPath( char **valuePtr, - size_t *lengthPtr, + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 32 Tcl_Obj *pathPtr, *objPtr; const char *str; @@ -580,16 +575,10 @@ Tcl_SetSystemEncoding(NULL, Tcl_GetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } -void -TclpSetInterfaces(void) -{ - /* do nothing */ -} - static const char * SearchKnownEncodings( const char *encoding) { int left = 0; @@ -888,14 +877,11 @@ osInfoInitialized = 1; } GetSystemInfo(&sysInfo); - if (osInfo.dwPlatformId < NUMPLATFORMS) { - Tcl_SetVar2(interp, "tcl_platform", "os", - platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY); - } + Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY); sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); if (sysInfo.wProcessorArchitecture < NUMPROCESSORS) { Tcl_SetVar2(interp, "tcl_platform", "machine", processors[sysInfo.wProcessorArchitecture], Index: unix/tclUnixNotfy.c ================================================================== --- unix/tclUnixNotfy.c +++ unix/tclUnixNotfy.c @@ -530,17 +530,17 @@ } } numFound = poll(pollFds, 1, pollTimeout); if (numFound == 1) { result = 0; - if (pollFds[0].events & (POLLIN | POLLHUP)) { + if (pollFds[0].revents & (POLLIN | POLLHUP)) { result |= TCL_READABLE; } - if (pollFds[0].events & POLLOUT) { + if (pollFds[0].revents & POLLOUT) { result |= TCL_WRITABLE; } - if (pollFds[0].events & POLLERR) { + if (pollFds[0].revents & POLLERR) { result |= TCL_EXCEPTION; } if (result) { break; } Index: unix/tclUnixPort.h ================================================================== --- unix/tclUnixPort.h +++ unix/tclUnixPort.h @@ -85,12 +85,12 @@ # define SOCKET unsigned int # define WSAEWOULDBLOCK 10035 typedef unsigned short WCHAR; __declspec(dllimport) extern __stdcall int GetModuleHandleExW(unsigned int, const char *, void *); __declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const char *, int); - __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const char *, int, - const char *, int, const char *, const char *); + __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const void *, int, + char *, int, const char *, void *); __declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int, WCHAR *, int); __declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *); __declspec(dllimport) extern __stdcall int IsDebuggerPresent(); __declspec(dllimport) extern __stdcall int GetLastError(); @@ -179,17 +179,11 @@ * for an alternative definition. If no other alternative is available we use * a reasonable guess. *--------------------------------------------------------------------------- */ -#ifndef NO_FLOAT_H -# include -#else -#ifndef NO_VALUES_H -# include -#endif -#endif +#include #ifndef FLT_MAX # ifdef MAXFLOAT # define FLT_MAX MAXFLOAT # else Index: unix/tclUnixSock.c ================================================================== --- unix/tclUnixSock.c +++ unix/tclUnixSock.c @@ -215,11 +215,11 @@ */ static void InitializeHostName( char **valuePtr, - size_t *lengthPtr, + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { const char *native = NULL; #ifndef NO_UNAME Index: unix/tclUnixThrd.c ================================================================== --- unix/tclUnixThrd.c +++ unix/tclUnixThrd.c @@ -13,15 +13,17 @@ #include "tclInt.h" #ifdef TCL_THREADS +#ifndef TCL_NO_DEPRECATED typedef struct { char nabuf[16]; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; +#endif /* * masterLock is used to serialize creation of mutexes, condition variables, * and thread local storage. This is the only place that can count on the * ability to statically initialize the mutex. Index: win/Makefile.in ================================================================== --- win/Makefile.in +++ win/Makefile.in @@ -628,11 +628,11 @@ echo "Making directory $$i"; \ $(MKDIR) $$i; \ else true; \ fi; \ done; - @for i in http1.0 opt0.4 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform; \ + @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ $(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \ else true; \ @@ -656,24 +656,24 @@ @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; @echo "Installing package http 2.8.12 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/http-2.8.12.tm; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.12.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/msgcat-1.6.1.tm; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/tcltest-2.4.0.tm; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/platform-1.0.14.tm; + @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/platform/shell-1.1.4.tm; + @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ done; @@ -856,11 +856,11 @@ "$(GENERIC_DIR_NATIVE)/tclOO.decls" # # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool -# workspace. It depends on the Tcl & Tk being in directories called tcl9.* & +# workspace. It depends on the Tcl & Tk being in directories called tcl8.* & # tk8.* up two directories from the TOOL_DIR. # TOOL_DIR=$(ROOT_DIR)/tools HTML_INSTALL_DIR=$(ROOT_DIR)/html Index: win/README ================================================================== --- win/README +++ win/README @@ -1,6 +1,6 @@ -Tcl 9.0 for Windows +Tcl 8.7 for Windows 1. Introduction --------------- This is the directory where you configure and compile the Windows @@ -14,11 +14,11 @@ 2. Compiling Tcl ---------------- In order to compile Tcl for Windows, you need the following: - Tcl 9.0 Source Distribution (plus any patches) + Tcl 8.7 Source Distribution (plus any patches) and Visual C++ 6 or newer @@ -77,13 +77,13 @@ Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. -Note that in order to run tclsh90.exe, you must ensure that tcl90.dll is +Note that in order to run tclsh87.exe, you must ensure that tcl87.dll is on your path, in the system directory, or in the directory containing -tclsh90.exe. +tclsh87.exe. Note: Tcl no longer provides support for Win32s. 3. Test suite ------------- DELETED win/coffbase.txt Index: win/coffbase.txt ================================================================== --- win/coffbase.txt +++ /dev/null @@ -1,43 +0,0 @@ -; -; This file defines the virtual base addresses for the Dynamic Link Libraries -; that are part of the Tcl system. The first token on a line is the key (or name -; of the DLL) and the second token is the virtual base address, in hexidecimal. -; The third token is the maximum size of the DLL image file, including symbols. -; -; Using a specified "prefered load address" should speed loading time by avoiding -; relocations (NT supported only). It is assumed extension authors will contribute -; their modules to this grand-master list. You can use the dumpbin utility with -; the /headers option to get the "size of image" data (already in hex). If the -; maximum size is too small a linker warning will occur. Modules can overlap when -; they're mutually exclusive. This info is placed in the DLL's PE header by the -; linker with the `-base:@$(TCLDIR)\win\coffbase.txt,` option. - -tcl 0x10000000 0x00200000 -tcldde 0x10200000 0x00010000 -tclreg 0x10210000 0x00010000 -tk 0x10220000 0x00200000 -expect 0x10480000 0x00080000 -itcl 0x10500000 0x00080000 -itk 0x10580000 0x00080000 -bltlite 0x10600000 0x00080000 -blt 0x10680000 0x00080000 -iocpsock 0x10700000 0x00080000 -tls 0x10780000 0x00100000 -winico 0x10880000 0x00010000 -sample 0x108B0000 0x00010000 -tile 0x10900000 0x00080000 -memchan 0x109D0000 0x00010000 -tdom 0x109E0000 0x00080000 -tclvfs 0x10A70000 0x00010000 -tkvideo 0x10B00000 0x00010000 -tclsdl 0x10B20000 0x00080000 -vqtcl 0x10C00000 0x00010000 -tdbc 0x10C40000 0x00010000 -thread 0x10C80000 0x00020000 -nsf 0x10ca0000 0x00080000 -; -; insert new packages here -; -snack 0x1E000000 0x00400000 -sound 0x1E400000 0x00400000 -snackogg 0x1E800000 0x00200000 Index: win/configure ================================================================== --- win/configure +++ win/configure @@ -704,11 +704,10 @@ ZLIB_DLL_FILE CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG DL_LIBS -CELIB_DIR CYGPATH TCL_THREADS SET_MAKE RC RANLIB @@ -766,12 +765,10 @@ enable_option_checking enable_threads with_encoding enable_shared enable_64bit -enable_wince -with_celib enable_symbols enable_embedded_manifest ' ac_precious_vars='build_alias host_alias @@ -1390,20 +1387,18 @@ --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-threads build with threads (default: on) --enable-shared build and link with shared libraries (default: on) --enable-64bit enable 64bit support (where applicable) - --enable-wince enable Win/CE support (where applicable) --enable-symbols build with debugging symbols (default: off) --enable-embedded-manifest embed manifest if possible (default: yes) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-encoding encoding for configuration values - --with-celib=DIR use Windows/CE support library from DIR Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a @@ -2097,14 +2092,14 @@ # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=9.0 -TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a0" +TCL_VERSION=8.7 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=7 +TCL_PATCH_LEVEL="a2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 @@ -3809,37 +3804,10 @@ fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5 $as_echo "$do64bit" >&6; } - # Cross-compiling options for Windows/CE builds - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if Windows/CE build is requested" >&5 -$as_echo_n "checking if Windows/CE build is requested... " >&6; } - # Check whether --enable-wince was given. -if test "${enable_wince+set}" = set; then : - enableval=$enable_wince; doWince=$enableval -else - doWince=no -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $doWince" >&5 -$as_echo "$doWince" >&6; } - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Windows/CE celib directory" >&5 -$as_echo_n "checking for Windows/CE celib directory... " >&6; } - -# Check whether --with-celib was given. -if test "${with_celib+set}" = set; then : - withval=$with_celib; CELIB_DIR=$withval -else - CELIB_DIR=NO_CELIB -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CELIB_DIR" >&5 -$as_echo "$CELIB_DIR" >&6; } - # Set some defaults (may get changed below) EXTRA_CFLAGS="" $as_echo "#define MODULE_SCOPE extern" >>confdefs.h @@ -4334,111 +4302,11 @@ CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="${lflags} -nologo" LINKBIN="link" fi - if test "$doWince" != "no" ; then - # Set defaults for common evc4/PPC2003 setup - # Currently Tcl requires 300+, possibly 420+ for sockets - CEVERSION=420; # could be 211 300 301 400 420 ... - TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... - ARCH=ARM; # could be ARM MIPS X86EM ... - PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" - if test "$doWince" != "yes"; then - # If !yes then the user specified something - # Reset ARCH to allow user to skip specifying it - ARCH= - eval `echo $doWince | awk -F "," '{ \ - if (length($1)) { printf "CEVERSION=\"%s\"\n", $1; \ - if ($1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ - if (length($2)) { printf "TARGETCPU=\"%s\"\n", toupper($2) }; \ - if (length($3)) { printf "ARCH=\"%s\"\n", toupper($3) }; \ - if (length($4)) { printf "PLATFORM=\"%s\"\n", $4 }; \ - }'` - if test "x${ARCH}" = "x" ; then - ARCH=$TARGETCPU; - fi - fi - OSVERSION=WCE$CEVERSION; - if test "x${WCEROOT}" = "x" ; then - WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" - if test ! -d "${WCEROOT}" ; then - WCEROOT="C:/Program Files/Microsoft eMbedded Tools" - fi - fi - if test "x${SDKROOT}" = "x" ; then - SDKROOT="C:/Program Files/Windows CE Tools" - if test ! -d "${SDKROOT}" ; then - SDKROOT="C:/Windows CE Tools" - fi - fi - # The space-based-path will work for the Makefile, but will - # not work if AC_TRY_COMPILE is called. - WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` - SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` - CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` - if test ! -d "${CELIB_DIR}/inc"; then - as_fn_error $? "Invalid celib directory \"${CELIB_DIR}\"" "$LINENO" 5 - fi - if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"\ - -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then - as_fn_error $? "could not find PocketPC SDK or target compiler to enable WinCE mode $CEVERSION,$TARGETCPU,$ARCH,$PLATFORM" "$LINENO" 5 - else - CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" - if test -d "${CEINCLUDE}/${TARGETCPU}" ; then - CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" - fi - CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" - fi - fi - - if test "$doWince" != "no" ; then - CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" - if test "${TARGETCPU}" = "X86"; then - CC="${CEBINROOT}/cl.exe" - else - CC="${CEBINROOT}/cl${ARCH}.exe" - fi - CC="\"${CC}\" -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" - RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" - arch=`echo ${ARCH} | awk '{print tolower($0)}'` - defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _DLL _WINDOWS" - for i in $defs ; do - cat >>confdefs.h <<_ACEOF -#define $i 1 -_ACEOF - - done -# if test "${ARCH}" = "X86EM"; then -# AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION) -# fi - cat >>confdefs.h <<_ACEOF -#define _WIN32_WCE $CEVERSION -_ACEOF - - cat >>confdefs.h <<_ACEOF -#define UNDER_CE $CEVERSION -_ACEOF - - CFLAGS_DEBUG="-nologo -Zi -Od" - CFLAGS_OPTIMIZE="-nologo -O2" - lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` - lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" - LINKBIN="\"${CEBINROOT}/link.exe\"" - - if test "${CEVERSION}" -lt 400 ; then - LIBS="coredll.lib corelibc.lib winsock.lib" - else - LIBS="coredll.lib corelibc.lib ws2.lib" - fi - # celib currently stuck at wce300 status - #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib" - LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\"" - LIBS_GUI="commctrl.lib commdlg.lib" - else - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" - fi + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" SHLIB_LD_LIBS='${LIBS}' # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" @@ -4465,11 +4333,11 @@ CC_OBJNAME="-Fo\$@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\"" # Specify linker flags depending on the type of app being # built -- Console vs. Window. - if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then + if test "${TARGETCPU}" != "X86"; then LDFLAGS_CONSOLE="-link ${lflags}" LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} else LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" Index: win/configure.ac ================================================================== --- win/configure.ac +++ win/configure.ac @@ -9,14 +9,14 @@ # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=9.0 -TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL="a0" +TCL_VERSION=8.7 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=7 +TCL_PATCH_LEVEL="a2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -1,1253 +1,947 @@ -#------------------------------------------------------------- -# makefile.vc -- -# -# Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Ajuba Solutions. -# Copyright (c) 2001-2005 ActiveState Corporation. -# Copyright (c) 2001-2004 David Gravereaux. -# Copyright (c) 2003-2008 Pat Thoyts. -#------------------------------------------------------------------------------ - -# Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or -# VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir) -!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR) -MSG = ^ -You need to run vcvars32.bat from Developer Studio or setenv.bat from the^ -Platform SDK first to setup the environment. Jump to this line to read^ -the build instructions. -!error $(MSG) -!endif - -#------------------------------------------------------------------------------ -# HOW TO USE this makefile: -# -# 1) It is now necessary to have MSVCDir, MSDevDir or MSSDK set in the -# environment. This is used as a check to see if vcvars32.bat had been -# run prior to running nmake or during the installation of Microsoft -# Visual C++, MSVCDir had been set globally and the PATH adjusted. -# Either way is valid. -# -# You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin -# directory to setup the proper environment, if needed, for your -# current setup. This is a needed bootstrap requirement and allows the -# swapping of different environments to be easier. -# -# 2) To use the Platform SDK (not expressly needed), run setenv.bat after -# vcvars32.bat according to the instructions for it. This can also -# turn on the 64-bit compiler, if your SDK has it. -# -# 3) Targets are: -# release -- Builds the core, the shell and the dlls. (default) -# dlls -- Just builds the windows extensions -# shell -- Just builds the shell and the core. -# core -- Only builds the core [tclXX.(dll|lib)]. -# all -- Builds everything. -# test -- Builds and runs the test suite. -# tcltest -- Just builds the test shell. -# install -- Installs the built binaries and libraries to $(INSTALLDIR) -# as the root of the install tree. -# tidy/clean/hose -- varying levels of cleaning. -# genstubs -- Rebuilds the Stubs table and support files (dev only). -# depend -- Generates an accurate set of source dependancies for this -# makefile. Helpful to avoid problems when the sources are -# refreshed and you rebuild, but can "overbuild" when common -# headers like tclInt.h just get small changes. -# htmlhelp -- Builds a Windows .chm help file for Tcl and Tk from the -# troff manual pages found in $(ROOT)\doc. You need to -# have installed the HTML Help Compiler package from Microsoft -# to produce the .chm file. -# winhelp -- (deprecated) Builds the windows .hlp file for Tcl from -# the troff man files found in $(ROOT)\doc. This type of -# help file is deprecated by Microsoft in favour of html -# help files (.chm) -# -# 4) Macros usable on the commandline: -# INSTALLDIR= -# Sets where to install Tcl from the built binaries. -# C:\Progra~1\Tcl is assumed when not specified. -# -# OPTS=loimpact,msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,tclalloc,unchecked,none -# Sets special options for the core. The default is for none. -# Any combination of the above may be used (comma separated). -# 'none' will over-ride everything to nothing. -# -# loimpact = Adds a flag for how NT treats the heap to keep memory -# in use, low. This is said to impact alloc performance. -# msvcrt = Affects the static option only to switch it from -# using libcmt(d) as the C runtime [by default] to -# msvcrt(d). This is useful for static embedding -# support. -# nothreads= Turns off full multithreading support. -# pdbs = Build detached symbols for release builds. -# profile = Adds profiling hooks. Map file is assumed. -# static = Builds a static library of the core instead of a -# dll. The static library will contain the dde and reg -# extensions. External applications who want to use -# this, need to link with the stub library as well as -# the static Tcl library.The shell will be static (and -# large), as well. -# staticpkg = Affects the static option only to switch -# tclshXX.exe to have the dde and reg extension linked -# inside it. -# symbols = Debug build. Links to the debug C runtime, disables -# optimizations and creates pdb symbols files. -# thrdalloc = Use the thread allocator (shared global free pool) -# This is the default on threaded builds. -# tclalloc = Use the old non-thread allocator -# unchecked= Allows a symbols build to not use the debug -# enabled runtime (msvcrt.dll not msvcrtd.dll -# or libcmt.lib not libcmtd.lib). -# -# STATS=compdbg,memdbg,none -# Sets optional memory and bytecode compiler debugging code added -# to the core. The default is for none. Any combination of the -# above may be used (comma separated). 'none' will over-ride -# everything to nothing. -# -# compdbg = Enables byte compilation logging. -# memdbg = Enables the debugging memory allocator. -# -# CHECKS=64bit,fullwarn,nodep,none -# Sets special macros for checking compatibility. -# -# 64bit = Enable 64bit portability warnings (if available) -# fullwarn = Builds with full compiler and link warnings enabled. -# Very verbose. -# nodep = Turns off compatibility macros to ensure the core -# isn't being built with deprecated functions. -# -# MACHINE=(ARM|AMD64|IA64|IX86) -# Set the machine type used for the compiler, linker, and -# resource compiler. This hook is needed to tell the tools -# when alternate platforms are requested. IX86 is the default -# when not specified. If the CPU environment variable has been -# set (ie: recent Platform SDK) then MACHINE is set from CPU. -# -# TMP_DIR= -# OUT_DIR= -# Hooks to allow the intermediate and output directories to be -# changed. $(OUT_DIR) is assumed to be -# $(BINROOT)\(Release|Debug) based on if symbols are requested. -# $(TMP_DIR) will de $(OUT_DIR)\ by default. -# -# TESTPAT= -# Reads the tests requested to be run from this file. -# -# CFG_ENCODING=encoding -# name of encoding for configuration information. Defaults -# to cp1252 -# -# 5) Examples: -# -# Basic syntax of calling nmake looks like this: -# nmake [-nologo] -f makefile.vc [target|macrodef [target|macrodef] [...]] -# -# Standard (no frills) -# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat -# Setting environment for using Microsoft Visual C++ tools. -# c:\tcl_src\win\>nmake -f makefile.vc release -# c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl -# -# Building for Win64 -# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat -# Setting environment for using Microsoft Visual C++ tools. -# c:\tcl_src\win\>c:\progra~1\platfo~1\setenv.bat /pre64 /RETAIL -# Targeting Windows pre64 RETAIL -# c:\tcl_src\win\>nmake -f makefile.vc MACHINE=IA64 -# -#------------------------------------------------------------------------------ -#============================================================================== -############################################################################### - - -# //==================================================================\\ -# >>[ -> Do not modify below this line. <- ]<< -# >>[ Please, use the commandline macros to modify how Tcl is built. ]<< -# >>[ If you need more features, send us a patch for more macros. ]<< -# \\==================================================================// - - -############################################################################### -#============================================================================== -#------------------------------------------------------------------------------ - -!if !exist("makefile.vc") -MSG = ^ -You must run this makefile only from the directory it is in.^ -Please `cd` to its location first. -!error $(MSG) -!endif - -PROJECT = tcl -!include "rules.vc" - -STUBPREFIX = $(PROJECT)stub -DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) -VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) - -DDEDOTVERSION = 1.4 -DDEVERSION = $(DDEDOTVERSION:.=) - -REGDOTVERSION = 1.3 -REGVERSION = $(REGDOTVERSION:.=) - -BINROOT = $(MAKEDIR) # originally . -ROOT = $(MAKEDIR)\.. # originally .. - -TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib -TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) -TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) - -TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib -TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) - -TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe -TCLSH = $(OUT_DIR)\$(TCLSHNAME) - -TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT) -TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME) - -TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT) -TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) - -TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe -CAT32 = $(OUT_DIR)\cat32.exe - -# Can we run what we build? IX86 runs on all architectures. -!ifndef TCLSH_NATIVE -!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" -TCLSH_NATIVE = $(TCLSH) -!else -!error You must explicitly set TCLSH_NATIVE for cross-compilation -!endif -!endif - -### Make sure we use backslash only. -LIB_INSTALL_DIR = $(_INSTALLDIR)\lib -BIN_INSTALL_DIR = $(_INSTALLDIR)\bin -DOC_INSTALL_DIR = $(_INSTALLDIR)\doc -SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(DOTVERSION) -INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include - -TCLSHOBJS = \ - $(TMP_DIR)\tclAppInit.obj \ -!if !$(STATIC_BUILD) -!if $(TCL_USE_STATIC_PACKAGES) - $(TMP_DIR)\tclWinReg.obj \ - $(TMP_DIR)\tclWinDde.obj \ -!endif -!endif - $(TMP_DIR)\tclsh.res - -TCLTESTOBJS = \ - $(TMP_DIR)\tclTest.obj \ - $(TMP_DIR)\tclTestObj.obj \ - $(TMP_DIR)\tclTestProcBodyObj.obj \ - $(TMP_DIR)\tclThreadTest.obj \ - $(TMP_DIR)\tclWinTest.obj \ -!if !$(STATIC_BUILD) -!if $(TCL_USE_STATIC_PACKAGES) - $(TMP_DIR)\tclWinReg.obj \ - $(TMP_DIR)\tclWinDde.obj \ -!endif -!endif - $(TMP_DIR)\testMain.obj - -COREOBJS = \ - $(TMP_DIR)\regcomp.obj \ - $(TMP_DIR)\regerror.obj \ - $(TMP_DIR)\regexec.obj \ - $(TMP_DIR)\regfree.obj \ - $(TMP_DIR)\tclAlloc.obj \ - $(TMP_DIR)\tclAssembly.obj \ - $(TMP_DIR)\tclAsync.obj \ - $(TMP_DIR)\tclBasic.obj \ - $(TMP_DIR)\tclBinary.obj \ - $(TMP_DIR)\tclCkalloc.obj \ - $(TMP_DIR)\tclClock.obj \ - $(TMP_DIR)\tclCmdAH.obj \ - $(TMP_DIR)\tclCmdIL.obj \ - $(TMP_DIR)\tclCmdMZ.obj \ - $(TMP_DIR)\tclCompCmds.obj \ - $(TMP_DIR)\tclCompCmdsGR.obj \ - $(TMP_DIR)\tclCompCmdsSZ.obj \ - $(TMP_DIR)\tclCompExpr.obj \ - $(TMP_DIR)\tclCompile.obj \ - $(TMP_DIR)\tclConfig.obj \ - $(TMP_DIR)\tclDate.obj \ - $(TMP_DIR)\tclDictObj.obj \ - $(TMP_DIR)\tclDisassemble.obj \ - $(TMP_DIR)\tclEncoding.obj \ - $(TMP_DIR)\tclEnsemble.obj \ - $(TMP_DIR)\tclEnv.obj \ - $(TMP_DIR)\tclEvent.obj \ - $(TMP_DIR)\tclExecute.obj \ - $(TMP_DIR)\tclFCmd.obj \ - $(TMP_DIR)\tclFileName.obj \ - $(TMP_DIR)\tclGet.obj \ - $(TMP_DIR)\tclHash.obj \ - $(TMP_DIR)\tclHistory.obj \ - $(TMP_DIR)\tclIndexObj.obj \ - $(TMP_DIR)\tclInterp.obj \ - $(TMP_DIR)\tclIO.obj \ - $(TMP_DIR)\tclIOCmd.obj \ - $(TMP_DIR)\tclIOGT.obj \ - $(TMP_DIR)\tclIOSock.obj \ - $(TMP_DIR)\tclIOUtil.obj \ - $(TMP_DIR)\tclIORChan.obj \ - $(TMP_DIR)\tclIORTrans.obj \ - $(TMP_DIR)\tclLink.obj \ - $(TMP_DIR)\tclListObj.obj \ - $(TMP_DIR)\tclLiteral.obj \ - $(TMP_DIR)\tclLoad.obj \ - $(TMP_DIR)\tclMain.obj \ - $(TMP_DIR)\tclMain2.obj \ - $(TMP_DIR)\tclNamesp.obj \ - $(TMP_DIR)\tclNotify.obj \ - $(TMP_DIR)\tclOO.obj \ - $(TMP_DIR)\tclOOBasic.obj \ - $(TMP_DIR)\tclOOCall.obj \ - $(TMP_DIR)\tclOODefineCmds.obj \ - $(TMP_DIR)\tclOOInfo.obj \ - $(TMP_DIR)\tclOOMethod.obj \ - $(TMP_DIR)\tclOOStubInit.obj \ - $(TMP_DIR)\tclObj.obj \ - $(TMP_DIR)\tclOptimize.obj \ - $(TMP_DIR)\tclPanic.obj \ - $(TMP_DIR)\tclParse.obj \ - $(TMP_DIR)\tclPathObj.obj \ - $(TMP_DIR)\tclPipe.obj \ - $(TMP_DIR)\tclPkg.obj \ - $(TMP_DIR)\tclPkgConfig.obj \ - $(TMP_DIR)\tclPosixStr.obj \ - $(TMP_DIR)\tclPreserve.obj \ - $(TMP_DIR)\tclProc.obj \ - $(TMP_DIR)\tclRegexp.obj \ - $(TMP_DIR)\tclResolve.obj \ - $(TMP_DIR)\tclResult.obj \ - $(TMP_DIR)\tclScan.obj \ - $(TMP_DIR)\tclStringObj.obj \ - $(TMP_DIR)\tclStrToD.obj \ - $(TMP_DIR)\tclStubInit.obj \ - $(TMP_DIR)\tclThread.obj \ - $(TMP_DIR)\tclThreadAlloc.obj \ - $(TMP_DIR)\tclThreadJoin.obj \ - $(TMP_DIR)\tclThreadStorage.obj \ - $(TMP_DIR)\tclTimer.obj \ - $(TMP_DIR)\tclTomMathInterface.obj \ - $(TMP_DIR)\tclTrace.obj \ - $(TMP_DIR)\tclUtf.obj \ - $(TMP_DIR)\tclUtil.obj \ - $(TMP_DIR)\tclVar.obj \ - $(TMP_DIR)\tclZlib.obj - -ZLIBOBJS = \ - $(TMP_DIR)\adler32.obj \ - $(TMP_DIR)\compress.obj \ - $(TMP_DIR)\crc32.obj \ - $(TMP_DIR)\deflate.obj \ - $(TMP_DIR)\infback.obj \ - $(TMP_DIR)\inffast.obj \ - $(TMP_DIR)\inflate.obj \ - $(TMP_DIR)\inftrees.obj \ - $(TMP_DIR)\trees.obj \ - $(TMP_DIR)\uncompr.obj \ - $(TMP_DIR)\zutil.obj - -TOMMATHOBJS = \ - $(TMP_DIR)\bncore.obj \ - $(TMP_DIR)\bn_reverse.obj \ - $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \ - $(TMP_DIR)\bn_fast_s_mp_sqr.obj \ - $(TMP_DIR)\bn_mp_add.obj \ - $(TMP_DIR)\bn_mp_add_d.obj \ - $(TMP_DIR)\bn_mp_and.obj \ - $(TMP_DIR)\bn_mp_clamp.obj \ - $(TMP_DIR)\bn_mp_clear.obj \ - $(TMP_DIR)\bn_mp_clear_multi.obj \ - $(TMP_DIR)\bn_mp_cmp.obj \ - $(TMP_DIR)\bn_mp_cmp_d.obj \ - $(TMP_DIR)\bn_mp_cmp_mag.obj \ - $(TMP_DIR)\bn_mp_cnt_lsb.obj \ - $(TMP_DIR)\bn_mp_copy.obj \ - $(TMP_DIR)\bn_mp_count_bits.obj \ - $(TMP_DIR)\bn_mp_div.obj \ - $(TMP_DIR)\bn_mp_div_d.obj \ - $(TMP_DIR)\bn_mp_div_2.obj \ - $(TMP_DIR)\bn_mp_div_2d.obj \ - $(TMP_DIR)\bn_mp_div_3.obj \ - $(TMP_DIR)\bn_mp_exch.obj \ - $(TMP_DIR)\bn_mp_expt_d.obj \ - $(TMP_DIR)\bn_mp_expt_d_ex.obj \ - $(TMP_DIR)\bn_mp_get_int.obj \ - $(TMP_DIR)\bn_mp_get_long.obj \ - $(TMP_DIR)\bn_mp_get_long_long.obj \ - $(TMP_DIR)\bn_mp_grow.obj \ - $(TMP_DIR)\bn_mp_init.obj \ - $(TMP_DIR)\bn_mp_init_copy.obj \ - $(TMP_DIR)\bn_mp_init_multi.obj \ - $(TMP_DIR)\bn_mp_init_set.obj \ - $(TMP_DIR)\bn_mp_init_set_int.obj \ - $(TMP_DIR)\bn_mp_init_size.obj \ - $(TMP_DIR)\bn_mp_karatsuba_mul.obj \ - $(TMP_DIR)\bn_mp_karatsuba_sqr.obj \ - $(TMP_DIR)\bn_mp_lshd.obj \ - $(TMP_DIR)\bn_mp_mod.obj \ - $(TMP_DIR)\bn_mp_mod_2d.obj \ - $(TMP_DIR)\bn_mp_mul.obj \ - $(TMP_DIR)\bn_mp_mul_2.obj \ - $(TMP_DIR)\bn_mp_mul_2d.obj \ - $(TMP_DIR)\bn_mp_mul_d.obj \ - $(TMP_DIR)\bn_mp_neg.obj \ - $(TMP_DIR)\bn_mp_or.obj \ - $(TMP_DIR)\bn_mp_radix_size.obj \ - $(TMP_DIR)\bn_mp_radix_smap.obj \ - $(TMP_DIR)\bn_mp_read_radix.obj \ - $(TMP_DIR)\bn_mp_rshd.obj \ - $(TMP_DIR)\bn_mp_set.obj \ - $(TMP_DIR)\bn_mp_set_int.obj \ - $(TMP_DIR)\bn_mp_set_long.obj \ - $(TMP_DIR)\bn_mp_set_long_long.obj \ - $(TMP_DIR)\bn_mp_shrink.obj \ - $(TMP_DIR)\bn_mp_sqr.obj \ - $(TMP_DIR)\bn_mp_sqrt.obj \ - $(TMP_DIR)\bn_mp_sub.obj \ - $(TMP_DIR)\bn_mp_sub_d.obj \ - $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \ - $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \ - $(TMP_DIR)\bn_mp_toom_mul.obj \ - $(TMP_DIR)\bn_mp_toom_sqr.obj \ - $(TMP_DIR)\bn_mp_toradix_n.obj \ - $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \ - $(TMP_DIR)\bn_mp_xor.obj \ - $(TMP_DIR)\bn_mp_zero.obj \ - $(TMP_DIR)\bn_s_mp_add.obj \ - $(TMP_DIR)\bn_s_mp_mul_digs.obj \ - $(TMP_DIR)\bn_s_mp_sqr.obj \ - $(TMP_DIR)\bn_s_mp_sub.obj - -PLATFORMOBJS = \ - $(TMP_DIR)\tclWin32Dll.obj \ - $(TMP_DIR)\tclWinChan.obj \ - $(TMP_DIR)\tclWinConsole.obj \ - $(TMP_DIR)\tclWinError.obj \ - $(TMP_DIR)\tclWinFCmd.obj \ - $(TMP_DIR)\tclWinFile.obj \ - $(TMP_DIR)\tclWinInit.obj \ - $(TMP_DIR)\tclWinLoad.obj \ - $(TMP_DIR)\tclWinNotify.obj \ - $(TMP_DIR)\tclWinPipe.obj \ - $(TMP_DIR)\tclWinSerial.obj \ - $(TMP_DIR)\tclWinSock.obj \ - $(TMP_DIR)\tclWinThrd.obj \ - $(TMP_DIR)\tclWinTime.obj \ -!if $(STATIC_BUILD) - $(TMP_DIR)\tclWinReg.obj \ - $(TMP_DIR)\tclWinDde.obj \ -!else - $(TMP_DIR)\tcl.res -!endif - -TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) - -TCLSTUBOBJS = \ - $(TMP_DIR)\tclStubLib.obj \ - $(TMP_DIR)\tclTomMathStubLib.obj \ - $(TMP_DIR)\tclOOStubLib.obj - -### The following paths CANNOT have spaces in them. -COMPATDIR = $(ROOT)\compat -DOCDIR = $(ROOT)\doc -GENERICDIR = $(ROOT)\generic -TOMMATHDIR = $(ROOT)\libtommath -TOOLSDIR = $(ROOT)\tools -WINDIR = $(ROOT)\win -PKGSDIR = $(ROOT)\pkgs - -#--------------------------------------------------------------------- -# Compile flags -#--------------------------------------------------------------------- - -!if !$(DEBUG) -!if $(OPTIMIZING) -### This cranks the optimization level to maximize speed -cdebug = -O2 $(OPTIMIZATIONS) -!else -cdebug = -!endif -!if $(SYMBOLS) -cdebug = $(cdebug) -Zi -!endif -!else if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" -### Warnings are too many, can't support warnings into errors. -cdebug = -Zi -Od $(DEBUGFLAGS) -!else -cdebug = -Zi -WX $(DEBUGFLAGS) -!endif - -### Common compiler options that are architecture specific -!if "$(MACHINE)" == "ARM" -carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE -!else -carch = -!endif - -### Declarations common to all compiler options -cwarn = $(WARNINGS) -D _CRT_SECURE_NO_DEPRECATE -D _CRT_NONSTDC_NO_DEPRECATE -cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ - -!if $(MSVCRT) -!if $(DEBUG) && !$(UNCHECKED) -crt = -MDd -!else -crt = -MD -!endif -!else -!if $(DEBUG) && !$(UNCHECKED) -crt = -MTd -!else -crt = -MT -!endif -!endif - -TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)" -TCL_DEFINES = -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1 -BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) $(TCL_DEFINES) -CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE -TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES) -STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES) - - -#--------------------------------------------------------------------- -# Link flags -#--------------------------------------------------------------------- - -!if $(DEBUG) -ldebug = -debug -debugtype:cv -!else -ldebug = -release -opt:ref -opt:icf,3 -!if $(SYMBOLS) -ldebug = $(ldebug) -debug -debugtype:cv -!endif -!endif - -### Declarations common to all linker options -lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) - -!if $(PROFILE) -lflags = $(lflags) -profile -!endif - -!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 -lflags = $(lflags) -nodefaultlib:libucrt.lib -!endif - -!if $(ALIGN98_HACK) && !$(STATIC_BUILD) -### Align sections for PE size savings. -lflags = $(lflags) -opt:nowin98 -!else if !$(ALIGN98_HACK) && $(STATIC_BUILD) -### Align sections for speed in loading by choosing the virtual page size. -lflags = $(lflags) -align:4096 -!endif - -!if $(LOIMPACT) -lflags = $(lflags) -ws:aggressive -!endif - -dlllflags = $(lflags) -dll -conlflags = $(lflags) -subsystem:console -guilflags = $(lflags) -subsystem:windows - -baselibs = netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib -# Avoid 'unresolved external symbol __security_cookie' errors. -# c.f. http://support.microsoft.com/?id=894573 -!if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" -!if $(VCVERSION) > 1399 && $(VCVERSION) < 1500 -baselibs = $(baselibs) bufferoverflowU.lib -!endif -!endif -!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 -baselibs = $(baselibs) ucrt.lib -!endif - -#--------------------------------------------------------------------- -# TclTest flags -#--------------------------------------------------------------------- - -!if "$(TESTPAT)" != "" -TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) -!endif - - -#--------------------------------------------------------------------- -# Project specific targets -#--------------------------------------------------------------------- - -release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs -core: setup $(TCLLIB) $(TCLSTUBLIB) -shell: setup $(TCLSH) -dlls: setup $(TCLREGLIB) $(TCLDDELIB) -all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs -tcltest: setup $(TCLTEST) dlls $(CAT32) -install: install-binaries install-libraries install-docs install-pkgs - -test: test-core test-pkgs -test-core: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT:\=/)/library -!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" - $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << - package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.3.2 [list load "$(TCLREGLIB:\=/)" registry] -<< -!else - @echo Please wait while the tests are collected... - $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log - package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.3.2 "$(TCLREGLIB:\=/)" registry] -<< - type tests.log | more -!endif - -runtest: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT:\=/)/library - $(DEBUGGER) $(TCLTEST) $(SCRIPT) - -runshell: setup $(TCLSH) dlls - set TCL_LIBRARY=$(ROOT:\=/)/library - $(DEBUGGER) $(TCLSH) $(SCRIPT) - -setup: - @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) - @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) - -!if !$(STATIC_BUILD) -$(TCLIMPLIB): $(TCLLIB) -!endif - -$(TCLLIB): $(TCLOBJS) -!if $(STATIC_BUILD) - $(lib32) -nologo $(LINKERFLAGS) -out:$@ @<< -$** -<< -!else - $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcl -out:$@ \ - $(baselibs) @<< -$** -<< - $(_VC_MANIFEST_EMBED_DLL) -!endif - -$(TCLSTUBLIB): $(TCLSTUBOBJS) - $(lib32) -nologo $(LINKERFLAGS) -nodefaultlib -out:$@ $(TCLSTUBOBJS) - -$(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) - $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** - $(_VC_MANIFEST_EMBED_EXE) - -$(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) - $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** - $(_VC_MANIFEST_EMBED_EXE) - -!if $(STATIC_BUILD) -$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj - $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** -!else -$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB) - $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \ - $** $(baselibs) - $(_VC_MANIFEST_EMBED_DLL) -!endif - -!if $(STATIC_BUILD) -$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj - $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** -!else -$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) - $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \ - $** $(baselibs) - $(_VC_MANIFEST_EMBED_DLL) -!endif - -pkgs: - @for /d %d in ($(PKGSDIR)\*) do \ - @if exist "%~fd\win\makefile.vc" ( \ - pushd "%~fd\win" & \ - $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) &\ - popd \ - ) - -test-pkgs: - @for /d %d in ($(PKGSDIR)\*) do \ - @if exist "%~fd\win\makefile.vc" ( \ - pushd "%~fd\win" & \ - $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) test &\ - popd \ - ) - -install-pkgs: - @for /d %d in ($(PKGSDIR)\*) do \ - @if exist "%~fd\win\makefile.vc" ( \ - pushd "%~fd\win" & \ - $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) install &\ - popd \ - ) - -clean-pkgs: - @for /d %d in ($(PKGSDIR)\*) do \ - @if exist "%~fd\win\makefile.vc" ( \ - pushd "%~fd\win" & \ - $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\ - popd \ - ) - -$(CAT32): $(WINDIR)\cat.c - $(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $? - $(link32) $(conlflags) -out:$@ -stack:16384 $(TMP_DIR)\cat.obj \ - $(baselibs) - $(_VC_MANIFEST_EMBED_EXE) - -#--------------------------------------------------------------------- -# Regenerate the stubs files. [Development use only] -#--------------------------------------------------------------------- - -genstubs: -!if !exist($(TCLSH)) - @echo Build tclsh first! -!else - $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ - $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \ - $(GENERICDIR:\=/)/tclTomMath.decls - $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ - $(GENERICDIR:\=/)/tclOO.decls -!endif - - -#---------------------------------------------------------------------- -# The following target generates the file generic/tclTomMath.h. -# It needs to be run (and the results checked) after updating -# to a new release of libtommath. -#---------------------------------------------------------------------- - -gentommath_h: -!if !exist($(TCLSH)) - @echo Build tclsh first! -!else - $(TCLSH) "$(TOOLSDIR:\=/)/fix_tommath_h.tcl" \ - "$(TOMMATHDIR:\=/)/tommath.h" \ - > "$(GENERICDIR)\tclTomMath.h" -!endif - -#--------------------------------------------------------------------- -# Build the Windows HTML help file. -#--------------------------------------------------------------------- - -# NOTE: you can define HHC on the command-line to override this -!ifndef HHC -HHC=""%ProgramFiles%\HTML Help Workshop\hhc.exe"" -!endif -HTMLDIR=$(OUT_DIR)\html -HTMLBASE=TclTk$(VERSION) -HHPFILE=$(HTMLDIR)\$(HTMLBASE).hhp -CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm - -htmlhelp: chmsetup $(CHMFILE) - -$(CHMFILE): $(DOCDIR)\* - @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl "--htmldir=$(HTMLDIR)" - @echo Compiling HTML help project - -$(HHC) <<$(HHPFILE) >NUL -[OPTIONS] -Compatibility=1.1 or later -Compiled file=$(HTMLBASE).chm -Default topic=contents.htm -Display compile progress=no -Error log file=$(HTMLBASE).log -Full-text search=Yes -Language=0x409 English (United States) -Title=Tcl/Tk $(DOT_VERSION) Help -[FILES] -contents.htm -docs.css -Keywords\*.htm -TclCmd\*.htm -TclLib\*.htm -TkCmd\*.htm -TkLib\*.htm -UserCmd\*.htm -<< - -chmsetup: - @if not exist $(HTMLDIR)\nul mkdir $(HTMLDIR) - -#------------------------------------------------------------------------- -# Build the old-style Windows .hlp file -#------------------------------------------------------------------------- - -TCLHLPBASE = $(PROJECT)$(VERSION) -HELPFILE = $(OUT_DIR)\$(TCLHLPBASE).hlp -HELPCNT = $(OUT_DIR)\$(TCLHLPBASE).cnt -DOCTMP_DIR = $(OUT_DIR)\$(PROJECT)_docs -HELPRTF = $(DOCTMP_DIR)\$(PROJECT).rtf -MAN2HELP = $(DOCTMP_DIR)\man2help.tcl -MAN2HELP2 = $(DOCTMP_DIR)\man2help2.tcl -INDEX = $(DOCTMP_DIR)\index.tcl -BMP = $(DOCTMP_DIR)\feather.bmp -BMP_NOPATH = feather.bmp -MAN2TCL = $(DOCTMP_DIR)\man2tcl.exe - -winhelp: docsetup $(HELPFILE) - -docsetup: - @if not exist $(DOCTMP_DIR)\nul mkdir $(DOCTMP_DIR) - -$(MAN2HELP) $(MAN2HELP2) $(INDEX) $(BMP): $(TOOLSDIR)\$$(@F) - @$(CPY) $(TOOLSDIR)\$(@F) $(@D) - -$(HELPFILE): $(HELPRTF) $(BMP) - cd $(DOCTMP_DIR) - start /wait hcrtf.exe -x <<$(PROJECT).hpj -[OPTIONS] -COMPRESS=12 Hall Zeck -LCID=0x409 0x0 0x0 ; English (United States) -TITLE=Tcl/Tk Reference Manual -BMROOT=. -CNT=$(@B).cnt -HLP=$(@B).hlp - -[FILES] -$(PROJECT).rtf - -[WINDOWS] -main="Tcl/Tk Reference Manual",,27648,(r15263976),(r65535) - -[CONFIG] -BrowseButtons() -CreateButton(1, "Web", ExecFile("http://www.tcl.tk")) -CreateButton(2, "SF", ExecFile("http://sf.net/projects/tcl")) -CreateButton(3, "Wiki", ExecFile("http://wiki.tcl.tk")) -CreateButton(4, "FAQ", ExecFile("http://www.purl.org/NET/Tcl-FAQ/")) -<< - cd $(MAKEDIR) - @$(CPY) "$(DOCTMP_DIR)\$(@B).hlp" "$(OUT_DIR)" - @$(CPY) "$(DOCTMP_DIR)\$(@B).cnt" "$(OUT_DIR)" - -$(MAN2TCL): $(TOOLSDIR)\$$(@B).c - $(cc32) $(TCL_CFLAGS) -Fo$(@D)\ $(TOOLSDIR)\$(@B).c - $(link32) $(conlflags) -out:$@ -stack:16384 $(@D)\man2tcl.obj - $(_VC_MANIFEST_EMBED_EXE) - -$(HELPRTF): $(MAN2TCL) $(MAN2HELP) $(MAN2HELP2) $(INDEX) $(DOCDIR)\* - $(TCLSH) $(MAN2HELP) -bitmap $(BMP_NOPATH) $(PROJECT) $(VERSION) $(DOCDIR:\=/) - -install-docs: -!if exist("$(CHMFILE)") - @echo Installing compiled HTML help - @$(CPY) "$(CHMFILE)" "$(DOC_INSTALL_DIR)\" -!endif -!if exist("$(HELPFILE)") - @echo Installing Windows help - @$(CPY) "$(HELPFILE)" "$(DOC_INSTALL_DIR)\" - @$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\" -!endif - -#--------------------------------------------------------------------- -# Build tclConfig.sh for the TEA build system. -#--------------------------------------------------------------------- - -tclConfig: $(OUT_DIR)\tclConfig.sh - -$(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in - @echo Creating tclConfig.sh - @nmakehlp -s << $** >$@ -@TCL_DLL_FILE@ $(TCLLIBNAME) -@TCL_VERSION@ $(DOTVERSION) -@TCL_MAJOR_VERSION@ $(TCL_MAJOR_VERSION) -@TCL_MINOR_VERSION@ $(TCL_MINOR_VERSION) -@TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL) -@CC@ $(CC) -@DEFS@ $(TCL_CFLAGS) -@CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd -@CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD -@LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv -@LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3 -@TCL_DBGX@ $(SUFX) -@TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib -@TCL_NEEDS_EXP_FILE@ -@LIBS@ $(baselibs) -@prefix@ $(_INSTALLDIR) -@exec_prefix@ $(BIN_INSTALL_DIR) -@SHLIB_CFLAGS@ -@STLIB_CFLAGS@ -@CFLAGS_WARNING@ -W3 -@EXTRA_CFLAGS@ -YX -@SHLIB_LD@ $(link32) $(dlllflags) -@STLIB_LD@ $(lib32) -nologo -@SHLIB_LD_LIBS@ $(baselibs) -@SHLIB_SUFFIX@ .dll -@DL_LIBS@ -@LDFLAGS@ -@TCL_CC_SEARCH_FLAGS@ -@TCL_LD_SEARCH_FLAGS@ -@LIBOBJS@ -@RANLIB@ -@TCL_LIB_FLAG@ -@TCL_BUILD_LIB_SPEC@ -@TCL_LIB_SPEC@ $(LIB_INSTALL_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib -@TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR) -@TCL_LIB_VERSIONS_OK@ -@TCL_SRC_DIR@ $(ROOT) -@TCL_PACKAGE_PATH@ -@TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME) -@TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME) -@TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME) -@TCL_THREADS@ $(TCL_THREADS) -@TCL_BUILD_STUB_LIB_SPEC@ -L$(OUT_DIR) $(TCLSTUBLIBNAME) -@TCL_BUILD_STUB_LIB_PATH@ $(TCLSTUBLIB) -@TCL_STUB_LIB_PATH@ $(LIB_INSTALL_DIR)\$(TCLSTUBLIBNAME) -@CFG_TCL_EXPORT_FILE_SUFFIX@ $(VERSION)$(SUFX).lib -@CFG_TCL_SHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).dll -@CFG_TCL_UNSHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).lib -!if $(STATIC_BUILD) -@TCL_SHARED_BUILD@ 0 -!else -@TCL_SHARED_BUILD@ 1 -!endif -<< - - -#--------------------------------------------------------------------- -# The following target generates the file generic/tclDate.c -# from the yacc grammar found in generic/tclGetDate.y. This is -# only run by hand as yacc is not available in all environments. -# The name of the .c file is different than the name of the .y file -# so that make doesn't try to automatically regenerate the .c file. -#--------------------------------------------------------------------- - -gendate: - bison --output-file=$(GENERICDIR)/tclDate.c \ - --name-prefix=TclDate \ - $(GENERICDIR)/tclGetDate.y - -#--------------------------------------------------------------------- -# Special case object file targets -#--------------------------------------------------------------------- - -$(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c - $(cc32) $(TCL_CFLAGS) -DTCL_TEST \ - -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ - -Fo$@ $? - -$(TMP_DIR)\tclMain2.obj: $(GENERICDIR)\tclMain.c - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -DTCL_ASCII_MAIN \ - -Fo$@ $? - -$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c - $(cc32) $(TCL_CFLAGS) -I$(COMPATDIR)\zlib -DBUILD_tcl -Fo$@ $? - -$(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c - $(cc32) -DBUILD_tcl $(TCL_CFLAGS) \ - -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ - -DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ - -DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ - -Fo$@ $? - -$(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c - $(cc32) $(TCL_CFLAGS) \ - -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ - -Fo$@ $? - -### The following objects should be built using the stub interfaces -### *ALL* extensions need to built with -DTCL_THREADS=1 - -$(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c -!if $(STATIC_BUILD) - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? -!else - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? -!endif - - -$(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c -!if $(STATIC_BUILD) - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? -!else - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? -!endif - - -### The following objects are part of the stub library and should not -### be built as DLL objects. -Zl is used to avoid a dependency on any -### specific C run-time. - -$(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c - $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? - -$(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c - $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? - -$(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c - $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? - -$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in - @nmakehlp -s << $** >$@ -@MACHINE@ $(MACHINE:IX86=X86) -@TCL_WIN_VERSION@ $(DOTVERSION).0.0 -<< - -#--------------------------------------------------------------------- -# Generate the source dependencies. Having dependency rules will -# improve incremental build accuracy without having to resort to a -# full rebuild just because some non-global header file like -# tclCompile.h was changed. These rules aren't needed when building -# from scratch. -#--------------------------------------------------------------------- - -depend: -!if !exist($(TCLSH)) - @echo Build tclsh first! -!else - $(TCLSH) $(TOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \ - -passthru:"-DBUILD_tcl $(TCL_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \ - $(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WINDIR),$$(WINDIR) @<< -$(TCLOBJS) -<< -!endif - -#--------------------------------------------------------------------- -# Dependency rules -#--------------------------------------------------------------------- - -!if exist("$(OUT_DIR)\depend.mk") -!include "$(OUT_DIR)\depend.mk" -!message *** Dependency rules in use. -!else -!message *** Dependency rules are not being used. -!endif - -### add a spacer in the output -!message - - -#--------------------------------------------------------------------- -# Implicit rules. A limitation exists with nmake that requires that -# source directory can not contain spaces in the path. This an -# absolute. -#--------------------------------------------------------------------- - -{$(WINDIR)}.c{$(TMP_DIR)}.obj:: - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< -$< -<< - -{$(TOMMATHDIR)}.c{$(TMP_DIR)}.obj:: - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< -$< -<< - -{$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< -$< -<< - -{$(COMPATDIR)}.c{$(TMP_DIR)}.obj:: - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< -$< -<< - -{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj:: - $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<< -$< -<< - -{$(WINDIR)}.rc{$(TMP_DIR)}.res: - $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ - -d DEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ - -d TCL_THREADS=$(TCL_THREADS) \ - -d STATIC_BUILD=$(STATIC_BUILD) \ - $< - -$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest - -.SUFFIXES: -.SUFFIXES:.c .rc - - -#--------------------------------------------------------------------- -# Installation. -#--------------------------------------------------------------------- - -install-binaries: - @echo Installing to '$(_INSTALLDIR)' - @echo Installing $(TCLLIBNAME) -!if "$(TCLLIB)" != "$(TCLIMPLIB)" - @$(CPY) "$(TCLLIB)" "$(BIN_INSTALL_DIR)\" -!endif - @$(CPY) "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\" -!if exist($(TCLSH)) - @echo Installing $(TCLSHNAME) - @$(CPY) "$(TCLSH)" "$(BIN_INSTALL_DIR)\" -!endif - @echo Installing $(TCLSTUBLIBNAME) - @$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\" - -#" emacs fix - -install-libraries: tclConfig install-msgs install-tzdata - @if not exist "$(SCRIPT_INSTALL_DIR)$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform" - @echo Installing header files - @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(TOMMATHDIR)\tommath_class.h" "$(INCLUDE_INSTALL_DIR)\" - @$(CPY) "$(TOMMATHDIR)\tommath_superclass.h" "$(INCLUDE_INSTALL_DIR)\" - @echo Installing library files to $(SCRIPT_INSTALL_DIR) - @$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\" - @$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\" - @$(CPY) "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\" - @echo Installing library http1.0 directory - @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \ - "$(SCRIPT_INSTALL_DIR)\http1.0\" - @echo Installing library opt0.4 directory - @$(CPY) "$(ROOT)\library\opt\*.tcl" \ - "$(SCRIPT_INSTALL_DIR)\opt0.4\" - @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module - @$(COPY) "$(ROOT)\library\http\http.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\http-$(PKG_HTTP_VER).tm" - @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module - @$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\msgcat-$(PKG_MSGCAT_VER).tm" - @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module - @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\tcltest-$(PKG_TCLTEST_VER).tm" - @echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module - @$(COPY) "$(ROOT)\library\platform\platform.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform-$(PKG_PLATFORM_VER).tm" - @echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module - @$(COPY) "$(ROOT)\library\platform\shell.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform\shell-$(PKG_SHELL_VER).tm" - @echo Installing $(TCLDDELIBNAME) -!if $(STATIC_BUILD) -!if !$(TCL_USE_STATIC_PACKAGES) - @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\" -!endif -!else - @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" - @$(CPY) "$(ROOT)\library\dde\pkgIndex.tcl" \ - "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" -!endif - @echo Installing $(TCLREGLIBNAME) -!if $(STATIC_BUILD) -!if !$(TCL_USE_STATIC_PACKAGES) - @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\" -!endif -!else - @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\" - @$(CPY) "$(ROOT)\library\reg\pkgIndex.tcl" \ - "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\" -!endif - @echo Installing encodings - @$(CPY) "$(ROOT)\library\encoding\*.enc" \ - "$(SCRIPT_INSTALL_DIR)\encoding\" - -#" emacs fix - -install-tzdata: - @echo Installing time zone data - @set TCL_LIBRARY=$(ROOT:\=/)/library - @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ - "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" - -install-msgs: - @echo Installing message catalogs - @set TCL_LIBRARY=$(ROOT:\=/)/library - @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ - "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" - -#--------------------------------------------------------------------- -# Clean up -#--------------------------------------------------------------------- - -tidy: -!if "$(TCLLIB)" != "$(TCLIMPLIB)" - @echo Removing $(TCLLIB) ... - @if exist $(TCLLIB) del $(TCLLIB) -!endif - @echo Removing $(TCLIMPLIB) ... - @if exist $(TCLIMPLIB) del $(TCLIMPLIB) - @echo Removing $(TCLSH) ... - @if exist $(TCLSH) del $(TCLSH) - @echo Removing $(TCLTEST) ... - @if exist $(TCLTEST) del $(TCLTEST) - @echo Removing $(TCLDDELIB) ... - @if exist $(TCLDDELIB) del $(TCLDDELIB) - @echo Removing $(TCLREGLIB) ... - @if exist $(TCLREGLIB) del $(TCLREGLIB) - -clean: clean-pkgs - @echo Cleaning $(TMP_DIR)\* ... - @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) - @echo Cleaning $(WINDIR)\nmakehlp.obj ... - @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj - @echo Cleaning $(WINDIR)\nmakehlp.exe ... - @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe - @echo Cleaning $(WINDIR)\nmhlp-out.txt ... - @if exist $(WINDIR)\nmhlp-out.txt del $(WINDIR)\nmhlp-out.txt - @echo Cleaning $(WINDIR)\_junk.pch ... - @if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch - @echo Cleaning $(WINDIR)\vercl.x ... - @if exist $(WINDIR)\vercl.x del $(WINDIR)\vercl.x - @echo Cleaning $(WINDIR)\vercl.i ... - @if exist $(WINDIR)\vercl.i del $(WINDIR)\vercl.i - @echo Cleaning $(WINDIR)\versions.vc ... - @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc - -realclean: hose - -hose: - @echo Hosing $(OUT_DIR)\* ... - @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) - -# Local Variables: -# mode: makefile -# End: +#------------------------------------------------------------- -*- makefile -*- +# +# Microsoft Visual C++ makefile for building Tcl with nmake +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright (c) 2001-2005 ActiveState Corporation. +# Copyright (c) 2001-2004 David Gravereaux. +# Copyright (c) 2003-2008 Pat Thoyts. +# Copyright (c) 2017 Ashok P. Nadkarni +#------------------------------------------------------------------------------ + +# General usage: +# nmake [-nologo] -f makefile.vc [TARGET|MACRODEF [TARGET|MACRODEF] [...]] +# +# For MACRODEF, see TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) +# or examine Sections 6-8 in rules.vc. +# +# Possible values of TARGET are: +# release -- Builds the core, the shell and the dlls. (default) +# dlls -- Just builds the windows extensions +# shell -- Just builds the shell and the core. +# core -- Only builds the core [tclXX.(dll|lib)]. +# all -- Builds everything. +# test -- Builds and runs the test suite. +# tcltest -- Just builds the test shell. +# install -- Installs the built binaries and libraries to $(INSTALLDIR) +# as the root of the install tree. +# tidy/clean/hose -- varying levels of cleaning. +# genstubs -- Rebuilds the Stubs table and support files (dev only). +# depend -- Generates an accurate set of source dependancies for this +# makefile. Helpful to avoid problems when the sources are +# refreshed and you rebuild, but can "overbuild" when common +# headers like tclInt.h just get small changes. +# htmlhelp -- Builds a Windows .chm help file for Tcl and Tk from the +# troff manual pages found in $(ROOT)\doc. You need to +# have installed the HTML Help Compiler package from Microsoft +# to produce the .chm file. +# +# The steps to setup a Visual C++ environment depend on which +# version of Visual Studio and/or the Windows SDK you are building +# against and are not described here. The simplest method is generally +# to start a command shell using one of the short cuts installed by +# Visual Studio/Windows SDK for the appropriate target architecture. +# +# NOTE: For older (Visual C++ 6 or the 2003 SDK), to use the Platform +# SDK (not expressly needed), run setenv.bat after +# vcvars32.bat according to the instructions for it. This can also +# turn on the 64-bit compiler, if your SDK has it. +# +# Examples: +# c:\tcl_src\win\>nmake -f makefile.vc release +# c:\tcl_src\win\>nmake -f makefile.vc test +# c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl +# c:\tcl_src\win\>nmake -f makefile.vc release OPTS=pdbs +# c:\tcl_src\win\>nmake -f makefile.vc release OPTS=symbols +# + +# NOTE: +# Before modifying this file, check whether the modification is applicable +# to building extensions as well and if so, modify rules.vc instead. + +# The PROJECT macro is used by rules.vc for generating appropriate +# macros and rules. +PROJECT = tcl + +# Default target to build if no target is specified. If unspecified, the +# rules.vc file will set up "all" as the target. +DEFAULT_BUILD_TARGET = release + +# We want to use our own resource file, not the standard template one. +RCFILE = tcl.rc + +# The rules.vc file does most of the hard work in terms of defining +# the build configuration, macros, output directories etc. +!include "rules.vc" + +# Tcl version info based on macros set up by rules.vc +DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) + +# We need versions of various core packages to generate appropriate +# file names during installation. +!if [echo REM = This file is generated from makefile.vc > versions.vc] +!endif +!if [echo PKG_HTTP_VER = \>> versions.vc] \ + && [nmakehlp -V ..\library\http\pkgIndex.tcl http >> versions.vc] +!endif +!if [echo PKG_TCLTEST_VER = \>> versions.vc] \ + && [nmakehlp -V ..\library\tcltest\pkgIndex.tcl tcltest >> versions.vc] +!endif +!if [echo PKG_MSGCAT_VER = \>> versions.vc] \ + && [nmakehlp -V ..\library\msgcat\pkgIndex.tcl msgcat >> versions.vc] +!endif +!if [echo PKG_PLATFORM_VER = \>> versions.vc] \ + && [nmakehlp -V ..\library\platform\pkgIndex.tcl "platform " >> versions.vc] +!endif +!if [echo PKG_SHELL_VER = \>> versions.vc] \ + && [nmakehlp -V ..\library\platform\pkgIndex.tcl "platform::shell" >> versions.vc] +!endif +!if [echo PKG_DDE_VER = \>> versions.vc] \ + && [nmakehlp -V ..\library\dde\pkgIndex.tcl "dde " >> versions.vc] +!endif +!if [echo PKG_REG_VER =\>> versions.vc] \ + && [nmakehlp -V ..\library\reg\pkgIndex.tcl registry >> versions.vc] +!endif + +!include versions.vc + +DDEDOTVERSION = 1.4 +DDEVERSION = $(DDEDOTVERSION:.=) + +REGDOTVERSION = 1.3 +REGVERSION = $(REGDOTVERSION:.=) + +TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT) +TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME) + +TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT) +TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) + +TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe +CAT32 = $(OUT_DIR)\cat32.exe + +TCLSHOBJS = \ + $(TMP_DIR)\tclAppInit.obj \ +!if !$(STATIC_BUILD) +!if $(TCL_USE_STATIC_PACKAGES) + $(TMP_DIR)\tclWinReg.obj \ + $(TMP_DIR)\tclWinDde.obj \ +!endif +!endif + $(TMP_DIR)\tclsh.res + +TCLTESTOBJS = \ + $(TMP_DIR)\tclTest.obj \ + $(TMP_DIR)\tclTestObj.obj \ + $(TMP_DIR)\tclTestProcBodyObj.obj \ + $(TMP_DIR)\tclThreadTest.obj \ + $(TMP_DIR)\tclWinTest.obj \ +!if !$(STATIC_BUILD) +!if $(TCL_USE_STATIC_PACKAGES) + $(TMP_DIR)\tclWinReg.obj \ + $(TMP_DIR)\tclWinDde.obj \ +!endif +!endif + $(TMP_DIR)\testMain.obj + +COREOBJS = \ + $(TMP_DIR)\regcomp.obj \ + $(TMP_DIR)\regerror.obj \ + $(TMP_DIR)\regexec.obj \ + $(TMP_DIR)\regfree.obj \ + $(TMP_DIR)\tclAlloc.obj \ + $(TMP_DIR)\tclAssembly.obj \ + $(TMP_DIR)\tclAsync.obj \ + $(TMP_DIR)\tclBasic.obj \ + $(TMP_DIR)\tclBinary.obj \ + $(TMP_DIR)\tclCkalloc.obj \ + $(TMP_DIR)\tclClock.obj \ + $(TMP_DIR)\tclCmdAH.obj \ + $(TMP_DIR)\tclCmdIL.obj \ + $(TMP_DIR)\tclCmdMZ.obj \ + $(TMP_DIR)\tclCompCmds.obj \ + $(TMP_DIR)\tclCompCmdsGR.obj \ + $(TMP_DIR)\tclCompCmdsSZ.obj \ + $(TMP_DIR)\tclCompExpr.obj \ + $(TMP_DIR)\tclCompile.obj \ + $(TMP_DIR)\tclConfig.obj \ + $(TMP_DIR)\tclDate.obj \ + $(TMP_DIR)\tclDictObj.obj \ + $(TMP_DIR)\tclDisassemble.obj \ + $(TMP_DIR)\tclEncoding.obj \ + $(TMP_DIR)\tclEnsemble.obj \ + $(TMP_DIR)\tclEnv.obj \ + $(TMP_DIR)\tclEvent.obj \ + $(TMP_DIR)\tclExecute.obj \ + $(TMP_DIR)\tclFCmd.obj \ + $(TMP_DIR)\tclFileName.obj \ + $(TMP_DIR)\tclGet.obj \ + $(TMP_DIR)\tclHash.obj \ + $(TMP_DIR)\tclHistory.obj \ + $(TMP_DIR)\tclIndexObj.obj \ + $(TMP_DIR)\tclInterp.obj \ + $(TMP_DIR)\tclIO.obj \ + $(TMP_DIR)\tclIOCmd.obj \ + $(TMP_DIR)\tclIOGT.obj \ + $(TMP_DIR)\tclIOSock.obj \ + $(TMP_DIR)\tclIOUtil.obj \ + $(TMP_DIR)\tclIORChan.obj \ + $(TMP_DIR)\tclIORTrans.obj \ + $(TMP_DIR)\tclLink.obj \ + $(TMP_DIR)\tclListObj.obj \ + $(TMP_DIR)\tclLiteral.obj \ + $(TMP_DIR)\tclLoad.obj \ + $(TMP_DIR)\tclMain.obj \ + $(TMP_DIR)\tclMain2.obj \ + $(TMP_DIR)\tclNamesp.obj \ + $(TMP_DIR)\tclNotify.obj \ + $(TMP_DIR)\tclOO.obj \ + $(TMP_DIR)\tclOOBasic.obj \ + $(TMP_DIR)\tclOOCall.obj \ + $(TMP_DIR)\tclOODefineCmds.obj \ + $(TMP_DIR)\tclOOInfo.obj \ + $(TMP_DIR)\tclOOMethod.obj \ + $(TMP_DIR)\tclOOStubInit.obj \ + $(TMP_DIR)\tclObj.obj \ + $(TMP_DIR)\tclOptimize.obj \ + $(TMP_DIR)\tclPanic.obj \ + $(TMP_DIR)\tclParse.obj \ + $(TMP_DIR)\tclPathObj.obj \ + $(TMP_DIR)\tclPipe.obj \ + $(TMP_DIR)\tclPkg.obj \ + $(TMP_DIR)\tclPkgConfig.obj \ + $(TMP_DIR)\tclPosixStr.obj \ + $(TMP_DIR)\tclPreserve.obj \ + $(TMP_DIR)\tclProc.obj \ + $(TMP_DIR)\tclRegexp.obj \ + $(TMP_DIR)\tclResolve.obj \ + $(TMP_DIR)\tclResult.obj \ + $(TMP_DIR)\tclScan.obj \ + $(TMP_DIR)\tclStringObj.obj \ + $(TMP_DIR)\tclStrToD.obj \ + $(TMP_DIR)\tclStubInit.obj \ + $(TMP_DIR)\tclThread.obj \ + $(TMP_DIR)\tclThreadAlloc.obj \ + $(TMP_DIR)\tclThreadJoin.obj \ + $(TMP_DIR)\tclThreadStorage.obj \ + $(TMP_DIR)\tclTimer.obj \ + $(TMP_DIR)\tclTomMathInterface.obj \ + $(TMP_DIR)\tclTrace.obj \ + $(TMP_DIR)\tclUtf.obj \ + $(TMP_DIR)\tclUtil.obj \ + $(TMP_DIR)\tclVar.obj \ + $(TMP_DIR)\tclZlib.obj + +ZLIBOBJS = \ + $(TMP_DIR)\adler32.obj \ + $(TMP_DIR)\compress.obj \ + $(TMP_DIR)\crc32.obj \ + $(TMP_DIR)\deflate.obj \ + $(TMP_DIR)\infback.obj \ + $(TMP_DIR)\inffast.obj \ + $(TMP_DIR)\inflate.obj \ + $(TMP_DIR)\inftrees.obj \ + $(TMP_DIR)\trees.obj \ + $(TMP_DIR)\uncompr.obj \ + $(TMP_DIR)\zutil.obj + +TOMMATHOBJS = \ + $(TMP_DIR)\bncore.obj \ + $(TMP_DIR)\bn_reverse.obj \ + $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \ + $(TMP_DIR)\bn_fast_s_mp_sqr.obj \ + $(TMP_DIR)\bn_mp_add.obj \ + $(TMP_DIR)\bn_mp_add_d.obj \ + $(TMP_DIR)\bn_mp_and.obj \ + $(TMP_DIR)\bn_mp_clamp.obj \ + $(TMP_DIR)\bn_mp_clear.obj \ + $(TMP_DIR)\bn_mp_clear_multi.obj \ + $(TMP_DIR)\bn_mp_cmp.obj \ + $(TMP_DIR)\bn_mp_cmp_d.obj \ + $(TMP_DIR)\bn_mp_cmp_mag.obj \ + $(TMP_DIR)\bn_mp_cnt_lsb.obj \ + $(TMP_DIR)\bn_mp_copy.obj \ + $(TMP_DIR)\bn_mp_count_bits.obj \ + $(TMP_DIR)\bn_mp_div.obj \ + $(TMP_DIR)\bn_mp_div_d.obj \ + $(TMP_DIR)\bn_mp_div_2.obj \ + $(TMP_DIR)\bn_mp_div_2d.obj \ + $(TMP_DIR)\bn_mp_div_3.obj \ + $(TMP_DIR)\bn_mp_exch.obj \ + $(TMP_DIR)\bn_mp_expt_d.obj \ + $(TMP_DIR)\bn_mp_expt_d_ex.obj \ + $(TMP_DIR)\bn_mp_get_int.obj \ + $(TMP_DIR)\bn_mp_get_long.obj \ + $(TMP_DIR)\bn_mp_get_long_long.obj \ + $(TMP_DIR)\bn_mp_grow.obj \ + $(TMP_DIR)\bn_mp_init.obj \ + $(TMP_DIR)\bn_mp_init_copy.obj \ + $(TMP_DIR)\bn_mp_init_multi.obj \ + $(TMP_DIR)\bn_mp_init_set.obj \ + $(TMP_DIR)\bn_mp_init_set_int.obj \ + $(TMP_DIR)\bn_mp_init_size.obj \ + $(TMP_DIR)\bn_mp_karatsuba_mul.obj \ + $(TMP_DIR)\bn_mp_karatsuba_sqr.obj \ + $(TMP_DIR)\bn_mp_lshd.obj \ + $(TMP_DIR)\bn_mp_mod.obj \ + $(TMP_DIR)\bn_mp_mod_2d.obj \ + $(TMP_DIR)\bn_mp_mul.obj \ + $(TMP_DIR)\bn_mp_mul_2.obj \ + $(TMP_DIR)\bn_mp_mul_2d.obj \ + $(TMP_DIR)\bn_mp_mul_d.obj \ + $(TMP_DIR)\bn_mp_neg.obj \ + $(TMP_DIR)\bn_mp_or.obj \ + $(TMP_DIR)\bn_mp_radix_size.obj \ + $(TMP_DIR)\bn_mp_radix_smap.obj \ + $(TMP_DIR)\bn_mp_read_radix.obj \ + $(TMP_DIR)\bn_mp_rshd.obj \ + $(TMP_DIR)\bn_mp_set.obj \ + $(TMP_DIR)\bn_mp_set_int.obj \ + $(TMP_DIR)\bn_mp_set_long.obj \ + $(TMP_DIR)\bn_mp_set_long_long.obj \ + $(TMP_DIR)\bn_mp_shrink.obj \ + $(TMP_DIR)\bn_mp_sqr.obj \ + $(TMP_DIR)\bn_mp_sqrt.obj \ + $(TMP_DIR)\bn_mp_sub.obj \ + $(TMP_DIR)\bn_mp_sub_d.obj \ + $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \ + $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \ + $(TMP_DIR)\bn_mp_toom_mul.obj \ + $(TMP_DIR)\bn_mp_toom_sqr.obj \ + $(TMP_DIR)\bn_mp_toradix_n.obj \ + $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \ + $(TMP_DIR)\bn_mp_xor.obj \ + $(TMP_DIR)\bn_mp_zero.obj \ + $(TMP_DIR)\bn_s_mp_add.obj \ + $(TMP_DIR)\bn_s_mp_mul_digs.obj \ + $(TMP_DIR)\bn_s_mp_sqr.obj \ + $(TMP_DIR)\bn_s_mp_sub.obj + +PLATFORMOBJS = \ + $(TMP_DIR)\tclWin32Dll.obj \ + $(TMP_DIR)\tclWinChan.obj \ + $(TMP_DIR)\tclWinConsole.obj \ + $(TMP_DIR)\tclWinError.obj \ + $(TMP_DIR)\tclWinFCmd.obj \ + $(TMP_DIR)\tclWinFile.obj \ + $(TMP_DIR)\tclWinInit.obj \ + $(TMP_DIR)\tclWinLoad.obj \ + $(TMP_DIR)\tclWinNotify.obj \ + $(TMP_DIR)\tclWinPipe.obj \ + $(TMP_DIR)\tclWinSerial.obj \ + $(TMP_DIR)\tclWinSock.obj \ + $(TMP_DIR)\tclWinThrd.obj \ + $(TMP_DIR)\tclWinTime.obj \ +!if $(STATIC_BUILD) + $(TMP_DIR)\tclWinReg.obj \ + $(TMP_DIR)\tclWinDde.obj \ +!else + $(TMP_DIR)\tcl.res +!endif + +TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) + +TCLSTUBOBJS = \ + $(TMP_DIR)\tclStubLib.obj \ + $(TMP_DIR)\tclTomMathStubLib.obj \ + $(TMP_DIR)\tclOOStubLib.obj + +### The following paths CANNOT have spaces in them as they appear on +### the left side of implicit rules. +TOMMATHDIR = $(ROOT)\libtommath +PKGSDIR = $(ROOT)\pkgs + +# Additional include and C macro definitions for the implicit rules +# defined in rules.vc +PRJ_INCLUDES = -I"$(TOMMATHDIR)" +PRJ_DEFINES = -DTCL_TOMMATH -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1 -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE + +# Additional Link libraries needed beyond those in rules.vc +PRJ_LIBS = netapi32.lib user32.lib userenv.lib ws2_32.lib + +#--------------------------------------------------------------------- +# TclTest flags +#--------------------------------------------------------------------- + +!if "$(TESTPAT)" != "" +TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) +!endif + + +#--------------------------------------------------------------------- +# Project specific targets +#--------------------------------------------------------------------- + +release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs +core: setup $(TCLLIB) $(TCLSTUBLIB) +shell: setup $(TCLSH) +dlls: setup $(TCLREGLIB) $(TCLDDELIB) +all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs +tcltest: setup $(TCLTEST) dlls $(CAT32) +install: install-binaries install-libraries install-docs install-pkgs +setup: default-setup + +test: test-core test-pkgs +test-core: setup $(TCLTEST) dlls $(CAT32) + set TCL_LIBRARY=$(ROOT:\=/)/library + $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << + package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] + package ifneeded registry 1.3.2 [list load "$(TCLREGLIB:\=/)" registry] +<< + +runtest: setup $(TCLTEST) dlls $(CAT32) + set TCL_LIBRARY=$(ROOT:\=/)/library + $(DEBUGGER) $(TCLTEST) $(SCRIPT) + +runshell: setup $(TCLSH) dlls + set TCL_LIBRARY=$(ROOT:\=/)/library + $(DEBUGGER) $(TCLSH) $(SCRIPT) + +!if $(STATIC_BUILD) + +$(TCLLIB): $(TCLOBJS) + $(LIBCMD) @<< +$** +<< + +!else + +$(TCLLIB): $(TCLOBJS) + $(DLLCMD) @<< +$** +<< + $(_VC_MANIFEST_EMBED_DLL) +$(TCLIMPLIB): $(TCLLIB) + +!endif # $(STATIC_BUILD) + + +$(TCLSTUBLIB): $(TCLSTUBOBJS) + $(LIBCMD) -nodefaultlib $(TCLSTUBOBJS) + +$(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) + $(CONEXECMD) -stack:2300000 $** + $(_VC_MANIFEST_EMBED_EXE) + +$(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) + $(CONEXECMD) -stack:2300000 $** + $(_VC_MANIFEST_EMBED_EXE) + +!if $(STATIC_BUILD) +$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj + $(LIBCMD) $** +!else +$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB) + $(DLLCMD) $** + $(_VC_MANIFEST_EMBED_DLL) +!endif + +!if $(STATIC_BUILD) +$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj + $(LIBCMD) $** +!else +$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) + $(DLLCMD) $** + $(_VC_MANIFEST_EMBED_DLL) +!endif + +pkgs: + @for /d %d in ($(PKGSDIR)\*) do \ + @if exist "%~fd\win\makefile.vc" ( \ + pushd "%~fd\win" & \ + $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) &\ + popd \ + ) + +test-pkgs: + @for /d %d in ($(PKGSDIR)\*) do \ + @if exist "%~fd\win\makefile.vc" ( \ + pushd "%~fd\win" & \ + $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) test &\ + popd \ + ) + +install-pkgs: + @for /d %d in ($(PKGSDIR)\*) do \ + @if exist "%~fd\win\makefile.vc" ( \ + pushd "%~fd\win" & \ + $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) install &\ + popd \ + ) + +clean-pkgs: + @for /d %d in ($(PKGSDIR)\*) do \ + @if exist "%~fd\win\makefile.vc" ( \ + pushd "%~fd\win" & \ + $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\ + popd \ + ) + +$(CAT32): $(WINDIR)\cat.c + $(cc32) $(cflags) $(crt) -D_CRT_NONSTDC_NO_DEPRECATE -DCONSOLE -Fo$(TMP_DIR)\ $? + $(CONEXECMD) -stack:16384 $(TMP_DIR)\cat.obj + $(_VC_MANIFEST_EMBED_EXE) + +#--------------------------------------------------------------------- +# Regenerate the stubs files. [Development use only] +#--------------------------------------------------------------------- + +genstubs: +!if !exist($(TCLSH)) + @echo Build tclsh first! +!else + $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ + $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \ + $(GENERICDIR:\=/)/tclTomMath.decls + $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ + $(GENERICDIR:\=/)/tclOO.decls +!endif + + +#---------------------------------------------------------------------- +# The following target generates the file generic/tclTomMath.h. +# It needs to be run (and the results checked) after updating +# to a new release of libtommath. +#---------------------------------------------------------------------- + +gentommath_h: +!if !exist($(TCLSH)) + @echo Build tclsh first! +!else + $(TCLSH) "$(TOOLSDIR:\=/)/fix_tommath_h.tcl" \ + "$(TOMMATHDIR:\=/)/tommath.h" \ + > "$(GENERICDIR)\tclTomMath.h" +!endif + +#--------------------------------------------------------------------- +# Build the Windows HTML help file. +#--------------------------------------------------------------------- + +# NOTE: you can define HHC on the command-line to override this. +# nmake does not set macro values if already set on the command line. +!if defined(PROCESSOR_ARCHITECTURE) && "$(PROCESSOR_ARCHITECTURE)" == "AMD64" +HHC="%ProgramFiles(x86)%\HTML Help Workshop\hhc.exe" +!else +HHC="%ProgramFiles%\HTML Help Workshop\hhc.exe" +!endif +HTMLDIR=$(OUT_DIR)\html +HTMLBASE=TclTk$(VERSION) +HHPFILE=$(HTMLDIR)\$(HTMLBASE).hhp +CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm + +htmlhelp: chmsetup $(CHMFILE) + +$(CHMFILE): $(DOCDIR)\* + @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl "--htmldir=$(HTMLDIR)" + @echo Compiling HTML help project + -"$(HHC)" <<$(HHPFILE) >NUL +[OPTIONS] +Compatibility=1.1 or later +Compiled file=$(HTMLBASE).chm +Default topic=contents.htm +Display compile progress=no +Error log file=$(HTMLBASE).log +Full-text search=Yes +Language=0x409 English (United States) +Title=Tcl/Tk $(DOTVERSION) Help +[FILES] +contents.htm +docs.css +Keywords\*.htm +TclCmd\*.htm +TclLib\*.htm +TkCmd\*.htm +TkLib\*.htm +UserCmd\*.htm +<< + +chmsetup: + @if not exist $(HTMLDIR)\nul mkdir $(HTMLDIR) + +install-docs: +!if exist("$(CHMFILE)") + @echo Installing compiled HTML help + @$(CPY) "$(CHMFILE)" "$(DOC_INSTALL_DIR)\" +!endif + +# "emacs font-lock highlighting fix + +#--------------------------------------------------------------------- +# Generate the tcl.nmake file which contains the options used to build +# Tcl itself. This is used when building extensions. +#--------------------------------------------------------------------- +tcl-nmake: $(OUT_DIR)\tcl.nmake +$(OUT_DIR)\tcl.nmake: + @type << >$@ +CORE_MACHINE = $(MACHINE) +CORE_DEBUG = $(DEBUG) +CORE_TCL_THREADS = $(TCL_THREADS) +CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC) +CORE_USE_WIDECHAR_API = $(USE_WIDECHAR_API) +<< + +#--------------------------------------------------------------------- +# Build tclConfig.sh for the TEA build system. +#--------------------------------------------------------------------- + +tclConfig: $(OUT_DIR)\tclConfig.sh + +# TBD - is this tclConfig.sh file ever used? The values are incorrect! +$(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in + @echo Creating tclConfig.sh + @nmakehlp -s << $** >$@ +@TCL_DLL_FILE@ $(TCLLIBNAME) +@TCL_VERSION@ $(DOTVERSION) +@TCL_MAJOR_VERSION@ $(TCL_MAJOR_VERSION) +@TCL_MINOR_VERSION@ $(TCL_MINOR_VERSION) +@TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL) +@CC@ $(CC) +@DEFS@ $(pkgcflags) +@CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd +@CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD +@LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv +@LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3 +@TCL_DBGX@ $(SUFX) +@TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib +@TCL_NEEDS_EXP_FILE@ +@LIBS@ $(baselibs) $(PRJ_LIBS) +@prefix@ $(_INSTALLDIR) +@exec_prefix@ $(BIN_INSTALL_DIR) +@SHLIB_CFLAGS@ +@STLIB_CFLAGS@ +@CFLAGS_WARNING@ -W3 +@EXTRA_CFLAGS@ -YX +@SHLIB_LD@ $(link32) $(dlllflags) +@STLIB_LD@ $(lib32) -nologo +@SHLIB_LD_LIBS@ $(baselibs) $(PRJ_LIBS) +@SHLIB_SUFFIX@ .dll +@DL_LIBS@ +@LDFLAGS@ +@TCL_CC_SEARCH_FLAGS@ +@TCL_LD_SEARCH_FLAGS@ +@LIBOBJS@ +@RANLIB@ +@TCL_LIB_FLAG@ +@TCL_BUILD_LIB_SPEC@ +@TCL_LIB_SPEC@ $(LIB_INSTALL_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib +@TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR) +@TCL_LIB_VERSIONS_OK@ +@TCL_SRC_DIR@ $(ROOT) +@TCL_PACKAGE_PATH@ +@TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME) +@TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME) +@TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME) +@TCL_THREADS@ $(TCL_THREADS) +@TCL_BUILD_STUB_LIB_SPEC@ -L$(OUT_DIR) $(TCLSTUBLIBNAME) +@TCL_BUILD_STUB_LIB_PATH@ $(TCLSTUBLIB) +@TCL_STUB_LIB_PATH@ $(LIB_INSTALL_DIR)\$(TCLSTUBLIBNAME) +@CFG_TCL_EXPORT_FILE_SUFFIX@ $(VERSION)$(SUFX).lib +@CFG_TCL_SHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).dll +@CFG_TCL_UNSHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).lib +!if $(STATIC_BUILD) +@TCL_SHARED_BUILD@ 0 +!else +@TCL_SHARED_BUILD@ 1 +!endif +<< + + +#--------------------------------------------------------------------- +# The following target generates the file generic/tclDate.c +# from the yacc grammar found in generic/tclGetDate.y. This is +# only run by hand as yacc is not available in all environments. +# The name of the .c file is different than the name of the .y file +# so that make doesn't try to automatically regenerate the .c file. +#--------------------------------------------------------------------- + +gendate: + bison --output-file=$(GENERICDIR)/tclDate.c \ + --name-prefix=TclDate \ + $(GENERICDIR)/tclGetDate.y + +#--------------------------------------------------------------------- +# Special case object file targets +#--------------------------------------------------------------------- + +$(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c + $(cc32) $(appcflags) -DTCL_TEST \ + -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ + -Fo$@ $? + +$(TMP_DIR)\tclMain2.obj: $(GENERICDIR)\tclMain.c + $(cc32) $(pkgcflags) -DTCL_ASCII_MAIN \ + -Fo$@ $? + +$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c + $(cc32) $(appcflags) -Fo$@ $? + +$(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c + $(cc32) $(appcflags) -Fo$@ $? + +$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c + $(CCAPPCMD) $? + +$(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c + $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -Fo$@ $? + +$(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c + $(cc32) $(pkgcflags) \ + -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ + -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ + -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ + -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ + -DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ + -DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ + -DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ + -DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ + -DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ + -DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ + -Fo$@ $? + +$(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c + $(cc32) $(appcflags) \ + -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ + -Fo$@ $? + +### The following objects should be built using the stub interfaces +### *ALL* extensions need to built with -DTCL_THREADS=1 + +$(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c +!if $(STATIC_BUILD) + $(cc32) $(appcflags) -DSTATIC_BUILD -Fo$@ $? +!else + $(cc32) $(appcflags) -DUSE_TCL_STUBS -Fo$@ $? +!endif + + +$(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c +!if $(STATIC_BUILD) + $(cc32) $(appcflags) -DSTATIC_BUILD -Fo$@ $? +!else + $(cc32) $(appcflags) -DUSE_TCL_STUBS -Fo$@ $? +!endif + + +### The following objects are part of the stub library and should not +### be built as DLL objects. -Zl is used to avoid a dependency on any +### specific C run-time. + +$(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c + $(cc32) $(stubscflags) -Fo$@ $? + +$(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c + $(cc32) $(stubscflags) -Fo$@ $? + +$(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c + $(cc32) $(stubscflags) -Fo$@ $? + +$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in + @nmakehlp -s << $** >$@ +@MACHINE@ $(MACHINE:IX86=X86) +@TCL_WIN_VERSION@ $(DOTVERSION).0.0 +<< + +#--------------------------------------------------------------------- +# Generate the source dependencies. Having dependency rules will +# improve incremental build accuracy without having to resort to a +# full rebuild just because some non-global header file like +# tclCompile.h was changed. These rules aren't needed when building +# from scratch. +#--------------------------------------------------------------------- + +depend: +!if !exist($(TCLSH)) + @echo Build tclsh first! +!else + $(TCLSH) $(TOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \ + -passthru:"-DBUILD_tcl $(TCL_INCLUDES) $(PRJ_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \ + $(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WINDIR),$$(WINDIR) @<< +$(TCLOBJS) +<< +!endif + +#--------------------------------------------------------------------- +# Dependency rules +#--------------------------------------------------------------------- + +!if exist("$(OUT_DIR)\depend.mk") +!include "$(OUT_DIR)\depend.mk" +!message *** Dependency rules in use. +!else +!message *** Dependency rules are not being used. +!endif + +### add a spacer in the output +!message + + +#--------------------------------------------------------------------- +# Implicit rules that are not covered by the common ones defined in +# rules.vc. A limitation exists with nmake that requires that +# source directory can not contain spaces in the path. This an +# absolute. +#--------------------------------------------------------------------- + +{$(TOMMATHDIR)}.c{$(TMP_DIR)}.obj:: + $(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<< +$< +<< + +{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj:: + $(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<< +$< +<< + +$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WINDIR)\tclsh.rc + + +#--------------------------------------------------------------------- +# Installation. +#--------------------------------------------------------------------- + +install-binaries: + @echo Installing to '$(_INSTALLDIR)' + @echo Installing $(TCLLIBNAME) +!if "$(TCLLIB)" != "$(TCLIMPLIB)" + @$(CPY) "$(TCLLIB)" "$(BIN_INSTALL_DIR)\" +!endif + @$(CPY) "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\" +!if exist($(TCLSH)) + @echo Installing $(TCLSHNAME) + @$(CPY) "$(TCLSH)" "$(BIN_INSTALL_DIR)\" +!endif + @echo Installing $(TCLSTUBLIBNAME) + @$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\" + +install-libraries: tclConfig tcl-nmake install-msgs install-tzdata + @if not exist "$(SCRIPT_INSTALL_DIR)" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6" + @if not exist "$(LIB_INSTALL_DIR)\nmake" \ + $(MKDIR) "$(LIB_INSTALL_DIR)\nmake" + @echo Installing header files + @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(TOMMATHDIR)\tommath_class.h" "$(INCLUDE_INSTALL_DIR)\" + @$(CPY) "$(TOMMATHDIR)\tommath_superclass.h" "$(INCLUDE_INSTALL_DIR)\" + @echo Installing library files to $(SCRIPT_INSTALL_DIR) + @$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\" + @$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\" + @$(CPY) "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\" + @$(CPY) "$(WINDIR)\rules.vc" "$(LIB_INSTALL_DIR)\nmake\" + @$(CPY) "$(WINDIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\" + @$(CPY) "$(WINDIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\" + @$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\" + @echo Installing library http1.0 directory + @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \ + "$(SCRIPT_INSTALL_DIR)\http1.0\" + @echo Installing library opt0.4 directory + @$(CPY) "$(ROOT)\library\opt\*.tcl" \ + "$(SCRIPT_INSTALL_DIR)\opt0.4\" + @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module + @$(COPY) "$(ROOT)\library\http\http.tcl" \ + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm" + @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module + @$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \ + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\msgcat-$(PKG_MSGCAT_VER).tm" + @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module + @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \ + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\tcltest-$(PKG_TCLTEST_VER).tm" + @echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module + @$(COPY) "$(ROOT)\library\platform\platform.tcl" \ + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform-$(PKG_PLATFORM_VER).tm" + @echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module + @$(COPY) "$(ROOT)\library\platform\shell.tcl" \ + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform\shell-$(PKG_SHELL_VER).tm" + @echo Installing $(TCLDDELIBNAME) +!if $(STATIC_BUILD) +!if !$(TCL_USE_STATIC_PACKAGES) + @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\" +!endif +!else + @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" + @$(CPY) "$(ROOT)\library\dde\pkgIndex.tcl" \ + "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" +!endif + @echo Installing $(TCLREGLIBNAME) +!if $(STATIC_BUILD) +!if !$(TCL_USE_STATIC_PACKAGES) + @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\" +!endif +!else + @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\" + @$(CPY) "$(ROOT)\library\reg\pkgIndex.tcl" \ + "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\" +!endif + @echo Installing encodings + @$(CPY) "$(ROOT)\library\encoding\*.enc" \ + "$(SCRIPT_INSTALL_DIR)\encoding\" +# "emacs font-lock highlighting fix + +install-tzdata: + @echo Installing time zone data + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" + +install-msgs: + @echo Installing message catalogs + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" + +#--------------------------------------------------------------------- +# Clean up +#--------------------------------------------------------------------- + +tidy: +!if "$(TCLLIB)" != "$(TCLIMPLIB)" + @echo Removing $(TCLLIB) ... + @if exist $(TCLLIB) del $(TCLLIB) +!endif + @echo Removing $(TCLIMPLIB) ... + @if exist $(TCLIMPLIB) del $(TCLIMPLIB) + @echo Removing $(TCLSH) ... + @if exist $(TCLSH) del $(TCLSH) + @echo Removing $(TCLTEST) ... + @if exist $(TCLTEST) del $(TCLTEST) + @echo Removing $(TCLDDELIB) ... + @if exist $(TCLDDELIB) del $(TCLDDELIB) + @echo Removing $(TCLREGLIB) ... + @if exist $(TCLREGLIB) del $(TCLREGLIB) + +clean: default-clean clean-pkgs +hose: default-hose +realclean: hose + +# Local Variables: +# mode: makefile +# End: Index: win/nmakehlp.c ================================================================== --- win/nmakehlp.c +++ win/nmakehlp.c @@ -37,18 +37,18 @@ #ifdef _MSC_VER #define snprintf _snprintf #endif - /* protos */ static int CheckForCompilerFeature(const char *option); static int CheckForLinkerFeature(const char **options, int count); static int IsIn(const char *string, const char *substring); static int SubstituteFile(const char *substs, const char *filename); static int QualifyPath(const char *path); +static int LocateDependency(const char *keyfile); static const char *GetVersionFromFile(const char *filename, const char *match, int numdots); static DWORD WINAPI ReadFromPipe(LPVOID args); /* globals */ @@ -170,10 +170,22 @@ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return QualifyPath(argv[2]); + + case 'L': + if (argc != 3) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -L keypath\n" + "Emit the fully qualified path of directory containing keypath\n" + "exitcodes: 0 == success, 1 == not found, 2 == error\n", argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 2; + } + return LocateDependency(argv[2]); } } chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -c|-f|-l|-Q|-s|-V ...\n" "This is a little helper app to equalize shell differences between WinNT and\n" @@ -697,10 +709,101 @@ PathCombine(szTmp, szCwd, szPath); PathCanonicalize(szCwd, szTmp); printf("%s\n", szCwd); return 0; } + +/* + * Implements LocateDependency for a single directory. See that command + * for an explanation. + * Returns 0 if found after printing the directory. + * Returns 1 if not found but no errors. + * Returns 2 on any kind of error + * Basically, these are used as exit codes for the process. + */ +static int LocateDependencyHelper(const char *dir, const char *keypath) +{ + HANDLE hSearch; + char path[MAX_PATH+1]; + int dirlen, keylen, ret; + WIN32_FIND_DATA finfo; + + if (dir == NULL || keypath == NULL) + return 2; /* Have no real error reporting mechanism into nmake */ + dirlen = strlen(dir); + if ((dirlen + 3) > sizeof(path)) + return 2; + strncpy(path, dir, dirlen); + strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */ + keylen = strlen(keypath); + +#if 0 /* This function is not available in Visual C++ 6 */ + /* + * Use numerics 0 -> FindExInfoStandard, + * 1 -> FindExSearchLimitToDirectories, + * as these are not defined in Visual C++ 6 + */ + hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0); +#else + hSearch = FindFirstFile(path, &finfo); +#endif + if (hSearch == INVALID_HANDLE_VALUE) + return 1; /* Not found */ + + /* Loop through all subdirs checking if the keypath is under there */ + ret = 1; /* Assume not found */ + do { + int sublen; + /* + * We need to check it is a directory despite the + * FindExSearchLimitToDirectories in the above call. See SDK docs + */ + if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) + continue; + sublen = strlen(finfo.cFileName); + if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) + continue; /* Path does not fit, assume not matched */ + strncpy(path+dirlen+1, finfo.cFileName, sublen); + path[dirlen+1+sublen] = '\\'; + strncpy(path+dirlen+1+sublen+1, keypath, keylen+1); + if (PathFileExists(path)) { + /* Found a match, print to stdout */ + path[dirlen+1+sublen] = '\0'; + QualifyPath(path); + ret = 0; + break; + } + } while (FindNextFile(hSearch, &finfo)); + FindClose(hSearch); + return ret; +} + +/* + * LocateDependency -- + * + * Locates a dependency for a package. + * keypath - a relative path within the package directory + * that is used to confirm it is the correct directory. + * The search path for the package directory is currently only + * the parent and grandparent of the current working directory. + * If found, the command prints + * name_DIRPATH= + * and returns 0. If not found, does not print anything and returns 1. + */ +static int LocateDependency(const char *keypath) +{ + int i, ret; + static char *paths[] = {"..", "..\\..", "..\\..\\.."}; + + for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) { + ret = LocateDependencyHelper(paths[i], keypath); + if (ret == 0) + return ret; + } + return ret; +} + /* * Local variables: * mode: c * c-basic-offset: 4 ADDED win/rules-ext.vc Index: win/rules-ext.vc ================================================================== --- /dev/null +++ win/rules-ext.vc @@ -0,0 +1,118 @@ +# This file should only be included in makefiles for Tcl extensions, +# NOT in the makefile for Tcl itself. + +!ifndef _RULES_EXT_VC + +# We need to run from the directory the parent makefile is located in. +# nmake does not tell us what makefile was used to invoke it so parent +# makefile has to set the MAKEFILEVC macro or we just make a guess and +# warn if we think that is not the case. +!if "$(MAKEFILEVC)" == "" + +!if exist("$(PROJECT).vc") +MAKEFILEVC = $(PROJECT).vc +!elseif exist("makefile.vc") +MAKEFILEVC = makefile.vc +!endif +!endif # "$(MAKEFILEVC)" == "" + +!if !exist("$(MAKEFILEVC)") +MSG = ^ +You must run nmake from the directory containing the project makefile.^ +If you are doing that and getting this message, set the MAKEFILEVC^ +macro to the name of the project makefile. +!message WARNING: $(MSG) +!endif + +!if "$(PROJECT)" == "tcl" +!error The rules-ext.vc file is not intended for Tcl itself. +!endif + +# We extract version numbers using the nmakehlp program. For now use +# the local copy of nmakehlp. Once we locate Tcl, we will use that +# one if it is newer. +!if [$(CC) -nologo "nmakehlp.c" -link -subsystem:console > nul] +!endif + +# First locate the Tcl directory that we are working with. +!if "$(TCLDIR)" != "" + +_RULESDIR = $(TCLDIR:/=\) + +!else + +# If an installation path is specified, that is also the Tcl directory. +# Also Tk never builds against an installed Tcl, it needs Tcl sources +!if defined(INSTALLDIR) && "$(PROJECT)" != "tk" +_RULESDIR=$(INSTALLDIR:/=\) +!else +# Locate Tcl sources +!if [echo _RULESDIR = \> nmakehlp.out] \ + || [nmakehlp -L generic\tcl.h >> nmakehlp.out] +_RULESDIR = ..\..\tcl +!else +!include nmakehlp.out +!endif + +!endif # defined(INSTALLDIR).... + +!endif # ifndef TCLDIR + +# Now look for the targets.vc file under the Tcl root. Note we check this +# file and not rules.vc because the latter also exists on older systems. +!if exist("$(_RULESDIR)\lib\nmake\targets.vc") # Building against installed Tcl +_RULESDIR = $(_RULESDIR)\lib\nmake +!elseif exist("$(_RULESDIR)\win\targets.vc") # Building against Tcl sources +_RULESDIR = $(_RULESDIR)\win +!else +# If we have not located Tcl's targets file, most likely we are compiling +# against an older version of Tcl and so must use our own support files. +_RULESDIR = . +!endif + +!if "$(_RULESDIR)" != "." +# Potentially using Tcl's support files. If this extension has its own +# nmake support files, need to compare the versions and pick newer. + +!if exist("rules.vc") # The extension has its own copy + +!if [echo TCL_RULES_MAJOR = \> versions.vc] \ + && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MAJOR >> versions.vc] +!endif +!if [echo TCL_RULES_MINOR = \>> versions.vc] \ + && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MINOR >> versions.vc] +!endif + +!if [echo OUR_RULES_MAJOR = \>> versions.vc] \ + && [nmakehlp -V "rules.vc" RULES_VERSION_MAJOR >> versions.vc] +!endif +!if [echo OUR_RULES_MINOR = \>> versions.vc] \ + && [nmakehlp -V "rules.vc" RULES_VERSION_MINOR >> versions.vc] +!endif +!include versions.vc +# We have a newer version of the support files, use them +!if ($(TCL_RULES_MAJOR) != $(OUR_RULES_MAJOR)) || ($(TCL_RULES_MINOR) < $(OUR_RULES_MINOR)) +_RULESDIR = . +!endif + +!endif # if exist("rules.vc") + +!endif # if $(_RULESDIR) != "." + +# Let rules.vc know what copy of nmakehlp.c to use. +NMAKEHLPC = $(_RULESDIR)\nmakehlp.c + +# Get rid of our internal defines before calling rules.vc +!undef TCL_RULES_MAJOR +!undef TCL_RULES_MINOR +!undef OUR_RULES_MAJOR +!undef OUR_RULES_MINOR + +!if exist("$(_RULESDIR)\rules.vc") +!message *** Using $(_RULESDIR)\rules.vc +!include "$(_RULESDIR)\rules.vc" +!else +!error *** Could not locate rules.vc in $(_RULESDIR) +!endif + +!endif # _RULES_EXT_VC Index: win/rules.vc ================================================================== --- win/rules.vc +++ win/rules.vc @@ -1,62 +1,437 @@ -#------------------------------------------------------------------------------ +#------------------------------------------------------------- -*- makefile -*- # rules.vc -- # -# Microsoft Visual C++ makefile include for decoding the commandline -# macros. This file does not need editing to build Tcl. +# Part of the nmake based build system for Tcl and its extensions. +# This file does all the hard work in terms of parsing build options, +# compiler switches, defining common targets and macros. The Tcl makefile +# directly includes this. Extensions include it via "rules-ext.vc". +# +# See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for +# detailed documentation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. # Copyright (c) 2003-2008 Patrick Thoyts +# Copyright (c) 2017 Ashok P. Nadkarni #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 -cc32 = $(CC) # built-in default. -link32 = link -lib32 = lib -rc32 = $(RC) # built-in default. - -!ifndef INSTALLDIR -### Assume the normal default. -_INSTALLDIR = C:\Program Files\Tcl +# The following macros define the version of the rules.vc nmake build system +# For modifications that are not backward-compatible, you *must* change +# the major version. +RULES_VERSION_MAJOR = 1 +RULES_VERSION_MINOR = 1 + +# The PROJECT macro must be defined by parent makefile. +!if "$(PROJECT)" == "" +!error *** Error: Macro PROJECT not defined! Please define it before including rules.vc +!endif + +!if "$(PRJ_PACKAGE_TCLNAME)" == "" +PRJ_PACKAGE_TCLNAME = $(PROJECT) +!endif + +# Also special case Tcl and Tk to save some typing later +DOING_TCL = 0 +DOING_TK = 0 +!if "$(PROJECT)" == "tcl" +DOING_TCL = 1 +!elseif "$(PROJECT)" == "tk" +DOING_TK = 1 +!endif + +!ifndef NEED_TK +# Backwards compatibility +!ifdef PROJECT_REQUIRES_TK +NEED_TK = $(PROJECT_REQUIRES_TK) +!else +NEED_TK = 0 +!endif +!endif + +!ifndef NEED_TCL_SOURCE +NEED_TCL_SOURCE = 0 +!endif + +!ifdef NEED_TK_SOURCE +!if $(NEED_TK_SOURCE) +NEED_TK = 1 +!endif !else -### Fix the path separators. -_INSTALLDIR = $(INSTALLDIR:/=\) +NEED_TK_SOURCE = 0 !endif + +################################################################ +# Nmake is a pretty weak environment in syntax and capabilities +# so this file is necessarily verbose. It's broken down into +# the following parts. +# +# 0. Sanity check that compiler environment is set up and initialize +# any built-in settings from the parent makefile +# 1. First define the external tools used for compiling, copying etc. +# as this is independent of everything else. +# 2. Figure out our build structure in terms of the directory, whether +# we are building Tcl or an extension, etc. +# 3. Determine the compiler and linker versions +# 4. Build the nmakehlp helper application +# 5. Determine the supported compiler options and features +# 6. Parse the OPTS macro value for user-specified build configuration +# 7. Parse the STATS macro value for statistics instrumentation +# 8. Parse the CHECKS macro for additional compilation checks +# 9. Extract Tcl, and possibly Tk, version numbers from the headers +# 10. Based on this selected configuration, construct the output +# directory and file paths +# 11. Construct the paths where the package is to be installed +# 12. Set up the actual options passed to compiler and linker based +# on the information gathered above. +# 13. Define some standard build targets and implicit rules. These may +# be optionally disabled by the parent makefile. +# 14. (For extensions only.) Compare the configuration of the target +# Tcl and the extensions and warn against discrepancies. +# +# One final note about the macro names used. They are as they are +# for historical reasons. We would like legacy extensions to +# continue to work with this make include file so be wary of +# changing them for consistency or clarity. + +# 0. Sanity check compiler environment + +# Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or +# VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir) + +!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR) +MSG = ^ +Visual C++ compiler environment not initialized. +!error $(MSG) +!endif + +# We need to run from the directory the parent makefile is located in. +# nmake does not tell us what makefile was used to invoke it so parent +# makefile has to set the MAKEFILEVC macro or we just make a guess and +# warn if we think that is not the case. +!if "$(MAKEFILEVC)" == "" + +!if exist("$(PROJECT).vc") +MAKEFILEVC = $(PROJECT).vc +!elseif exist("makefile.vc") +MAKEFILEVC = makefile.vc +!endif +!endif # "$(MAKEFILEVC)" == "" + +!if !exist("$(MAKEFILEVC)") +MSG = ^ +You must run nmake from the directory containing the project makefile.^ +If you are doing that and getting this message, set the MAKEFILEVC^ +macro to the name of the project makefile. +!message WARNING: $(MSG) +!endif + + +################################################################ +# 1. Define external programs being used #---------------------------------------------------------- # Set the proper copy method to avoid overwrite questions # to the user when copying files and selecting the right # "delete all" method. #---------------------------------------------------------- -!if "$(OS)" == "Windows_NT" RMDIR = rmdir /S /Q -ERRNULL = 2>NUL -!if ![ver | find "4.0" > nul] -CPY = echo y | xcopy /i >NUL -COPY = copy >NUL -!else CPY = xcopy /i /y >NUL +CPYDIR = xcopy /e /i /y >NUL COPY = copy /y >NUL -!endif -!else # "$(OS)" != "Windows_NT" -CPY = xcopy /i >_JUNK.OUT # On Win98 NUL does not work here. -COPY = copy >_JUNK.OUT # On Win98 NUL does not work here. -RMDIR = deltree /Y -NULL = \NUL # Used in testing directory existence -ERRNULL = >NUL # Win9x shell cannot redirect stderr -!endif MKDIR = mkdir -#------------------------------------------------------------------------------ -# Determine the host and target architectures and compiler version. -#------------------------------------------------------------------------------ +###################################################################### +# 2. Figure out our build environment in terms of what we're building. +# +# (a) Tcl itself +# (b) Tk +# (c) a Tcl extension using libraries/includes from an *installed* Tcl +# (d) a Tcl extension using libraries/includes from Tcl source directory +# +# This last is needed because some extensions still need +# some Tcl interfaces that are not publicly exposed. +# +# The fragment will set the following macros: +# ROOT - root of this module sources +# COMPATDIR - source directory that holds compatibility sources +# DOCDIR - source directory containing documentation files +# GENERICDIR - platform-independent source directory +# WINDIR - Windows-specific source directory +# TESTDIR - directory containing test files +# TOOLSDIR - directory containing build tools +# _TCLDIR - root of the Tcl installation OR the Tcl sources. Not set +# when building Tcl itself. +# _INSTALLDIR - native form of the installation path. For Tcl +# this will be the root of the Tcl installation. For extensions +# this will be the lib directory under the root. +# TCLINSTALL - set to 1 if _TCLDIR refers to +# headers and libraries from an installed Tcl, and 0 if built against +# Tcl sources. Not set when building Tcl itself. Yes, not very well +# named. +# _TCL_H - native path to the tcl.h file +# +# If Tk is involved, also sets the following +# _TKDIR - native form Tk installation OR Tk source. Not set if building +# Tk itself. +# TKINSTALL - set 1 if _TKDIR refers to installed Tk and 0 if Tk sources +# _TK_H - native path to the tk.h file + +# Root directory for sources and assumed subdirectories +ROOT = $(MAKEDIR)\.. +# The following paths CANNOT have spaces in them as they appear on the +# left side of implicit rules. +!ifndef COMPATDIR +COMPATDIR = $(ROOT)\compat +!endif +!ifndef DOCDIR +DOCDIR = $(ROOT)\doc +!endif +!ifndef GENERICDIR +GENERICDIR = $(ROOT)\generic +!endif +!ifndef TOOLSDIR +TOOLSDIR = $(ROOT)\tools +!endif +!ifndef TESTDIR +TESTDIR = $(ROOT)\tests +!endif +!ifndef LIBDIR +!if exist("$(ROOT)\library") +LIBDIR = $(ROOT)\library +!else +LIBDIR = $(ROOT)\lib +!endif +!endif +!ifndef DEMODIR +!if exist("$(LIBDIR)\demos") +DEMODIR = $(LIBDIR)\demos +!else +DEMODIR = $(ROOT)\demos +!endif +!endif # ifndef DEMODIR +# Do NOT enclose WINDIR in a !ifndef because Windows always defines +# WINDIR env var to point to c:\windows! +# TBD - This is a potentially dangerous conflict, rename WINDIR to +# something else +WINDIR = $(ROOT)\win + +!ifndef RCDIR +!if exist("$(WINDIR)\rc") +RCDIR = $(WINDIR)\rc +!else +RCDIR = $(WINDIR) +!endif +!endif +RCDIR = $(RCDIR:/=\) + +# The target directory where the built packages and binaries will be installed. +# INSTALLDIR is the (optional) path specified by the user. +# _INSTALLDIR is INSTALLDIR using the backslash separator syntax +!ifdef INSTALLDIR +### Fix the path separators. +_INSTALLDIR = $(INSTALLDIR:/=\) +!else +### Assume the normal default. +_INSTALLDIR = $(HOMEDRIVE)\Tcl +!endif + +!if $(DOING_TCL) + +# BEGIN Case 2(a) - Building Tcl itself + +# Only need to define _TCL_H +_TCL_H = ..\generic\tcl.h + +# END Case 2(a) - Building Tcl itself + +!elseif $(DOING_TK) + +# BEGIN Case 2(b) - Building Tk + +TCLINSTALL = 0 # Tk always builds against Tcl source, not an installed Tcl +!if "$(TCLDIR)" == "" +!if [echo TCLDIR = \> nmakehlp.out] \ + || [nmakehlp -L generic\tcl.h >> nmakehlp.out] +!error *** Could not locate Tcl source directory. +!endif +!include nmakehlp.out +!endif # TCLDIR == "" + +_TCLDIR = $(TCLDIR:/=\) +_TCL_H = $(_TCLDIR)\generic\tcl.h +!if !exist("$(_TCL_H)") +!error Could not locate tcl.h. Please set the TCLDIR macro to point to the Tcl *source* directory. +!endif + +_TK_H = ..\generic\tk.h + +# END Case 2(b) - Building Tk + +!else + +# BEGIN Case 2(c) or (d) - Building an extension other than Tk + +# If command line has specified Tcl location through TCLDIR, use it +# else default to the INSTALLDIR setting +!if "$(TCLDIR)" != "" + +_TCLDIR = $(TCLDIR:/=\) +!if exist("$(_TCLDIR)\include\tcl.h") # Case 2(c) with TCLDIR defined +TCLINSTALL = 1 +_TCL_H = $(_TCLDIR)\include\tcl.h +!elseif exist("$(_TCLDIR)\generic\tcl.h") # Case 2(d) with TCLDIR defined +TCLINSTALL = 0 +_TCL_H = $(_TCLDIR)\generic\tcl.h +!endif + +!else # # Case 2(c) for extensions with TCLDIR undefined + +# Need to locate Tcl depending on whether it needs Tcl source or not. +# If we don't, check the INSTALLDIR for an installed Tcl first + +!if exist("$(_INSTALLDIR)\include\tcl.h") && !$(NEED_TCL_SOURCE) + +TCLINSTALL = 1 +TCLDIR = $(_INSTALLDIR)\.. +# NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions +# later so the \.. accounts for the /lib +_TCLDIR = $(_INSTALLDIR)\.. +_TCL_H = $(_TCLDIR)\include\tcl.h + +!else # exist(...) && ! $(NEED_TCL_SOURCE) + +!if [echo _TCLDIR = \> nmakehlp.out] \ + || [nmakehlp -L generic\tcl.h >> nmakehlp.out] +!error *** Could not locate Tcl source directory. +!endif +!include nmakehlp.out +TCLINSTALL = 0 +TCLDIR = $(_TCLDIR) +_TCL_H = $(_TCLDIR)\generic\tcl.h + +!endif # exist(...) && ! $(NEED_TCL_SOURCE) + +!endif # TCLDIR + +!ifndef _TCL_H +MSG =^ +Failed to find tcl.h. The TCLDIR macro is set incorrectly or is not set and default path does not contain tcl.h. +!error $(MSG) +!endif + +# Now do the same to locate Tk headers and libs if project requires Tk +!if $(NEED_TK) + +!if "$(TKDIR)" != "" + +_TKDIR = $(TKDIR:/=\) +!if exist("$(_TKDIR)\include\tk.h") +TKINSTALL = 1 +_TK_H = $(_TKDIR)\include\tk.h +!elseif exist("$(_TKDIR)\generic\tk.h") +TKINSTALL = 0 +_TK_H = $(_TKDIR)\generic\tk.h +!endif + +!else # TKDIR not defined + +# Need to locate Tcl depending on whether it needs Tcl source or not. +# If we don't, check the INSTALLDIR for an installed Tcl first + +!if exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) + +TKINSTALL = 1 +# NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions +# later so the \.. accounts for the /lib +_TKDIR = $(_INSTALLDIR)\.. +_TK_H = $(_TKDIR)\include\tk.h +TKDIR = $(_TKDIR) + +!else # exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) + +!if [echo _TKDIR = \> nmakehlp.out] \ + || [nmakehlp -L generic\tk.h >> nmakehlp.out] +!error *** Could not locate Tk source directory. +!endif +!include nmakehlp.out +TKINSTALL = 0 +TKDIR = $(_TKDIR) +_TK_H = $(_TKDIR)\generic\tk.h + +!endif # exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) + +!endif # TKDIR + +!ifndef _TK_H +MSG =^ +Failed to find tk.h. The TKDIR macro is set incorrectly or is not set and default path does not contain tk.h. +!error $(MSG) +!endif + +!endif # NEED_TK + +!if $(NEED_TCL_SOURCE) && $(TCLINSTALL) +MSG = ^ +*** Warning: This extension requires the source distribution of Tcl.^ +*** Please set the TCLDIR macro to point to the Tcl sources. +!error $(MSG) +!endif + +!if $(NEED_TK_SOURCE) +!if $(TKINSTALL) +MSG = ^ +*** Warning: This extension requires the source distribution of Tk.^ +*** Please set the TKDIR macro to point to the Tk sources. +!error $(MSG) +!endif +!endif + + +# If INSTALLDIR set to tcl installation root dir then reset to the +# lib dir for installing extensions +!if exist("$(_INSTALLDIR)\include\tcl.h") +_INSTALLDIR=$(_INSTALLDIR)\lib +!endif + +# END Case 2(c) or (d) - Building an extension +!endif # if $(DOING_TCL) + +################################################################ +# 3. Determine compiler version and architecture +# In this section, we figure out the compiler version and the +# architecture for which we are building. This sets the +# following macros: +# VCVERSION - the internal compiler version as 1200, 1400, 1910 etc. +# This is also printed by the compiler in dotted form 19.10 etc. +# VCVER - the "marketing version", for example Visual C++ 6 for internal +# compiler version 1200. This is kept only for legacy reasons as it +# does not make sense for recent Microsoft compilers. Only used for +# output directory names. +# ARCH - set to IX86 or AMD64 depending on 32- or 64-bit target +# NATIVE_ARCH - set to IX86 or AMD64 for the host machine +# MACHINE - same as $(ARCH) - legacy +# _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed +# CFG_ENCODING - set to an character encoding. +# TBD - this is passed to compiler as TCL_CFGVAL_ENCODING but can't +# see where it is used + +cc32 = $(CC) # built-in default. +link32 = link +lib32 = lib +rc32 = $(RC) # built-in default. + +#---------------------------------------------------------------- +# Figure out the compiler architecture and version by writing +# the C macros to a file, preprocessing them with the C +# preprocessor and reading back the created file _HASH=^# _VC_MANIFEST_EMBED_EXE= _VC_MANIFEST_EMBED_DLL= VCVER=0 @@ -64,20 +439,47 @@ && ![echo $(_HASH)if defined(_M_IX86) >> vercl.x] \ && ![echo ARCH=IX86 >> vercl.x] \ && ![echo $(_HASH)elif defined(_M_AMD64) >> vercl.x] \ && ![echo ARCH=AMD64 >> vercl.x] \ && ![echo $(_HASH)endif >> vercl.x] \ - && ![cl -nologo -TC -P vercl.x $(ERRNULL)] + && ![$(cc32) -nologo -TC -P vercl.x 2>NUL] !include vercl.i +!if $(VCVERSION) < 1900 !if ![echo VCVER= ^\> vercl.vc] \ && ![set /a $(VCVERSION) / 100 - 6 >> vercl.vc] !include vercl.vc !endif +!else +# The simple calculation above does not apply to new Visual Studio releases +# Keep the compiler version in its native form. +VCVER = $(VCVERSION) !endif -!if ![del $(ERRNUL) /q/f vercl.x vercl.i vercl.vc] !endif +!if ![del 2>NUL /q/f vercl.x vercl.i vercl.vc] +!endif + +#---------------------------------------------------------------- +# The MACHINE macro is used by legacy makefiles so set it as well +!ifdef MACHINE +!if "$(MACHINE)" == "x86" +!undef MACHINE +MACHINE = IX86 +!elseif "$(MACHINE)" == "x64" +!undef MACHINE +MACHINE = AMD64 +!endif +!if "$(MACHINE)" != "$(ARCH)" +!error Specified MACHINE macro $(MACHINE) does not match detected target architecture $(ARCH). +!endif +!else +MACHINE=$(ARCH) +!endif + +#------------------------------------------------------------ +# Figure out the *host* architecture by reading the registry + !if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86] NATIVE_ARCH=IX86 !else NATIVE_ARCH=AMD64 !endif @@ -86,157 +488,227 @@ !if $(VCVERSION) >= 1400 _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !endif -!ifndef MACHINE -MACHINE=$(ARCH) -!endif - !ifndef CFG_ENCODING CFG_ENCODING = \"cp1252\" !endif -!message =============================================================================== - -#---------------------------------------------------------- -# build the helper app we need to overcome nmake's limiting -# environment. -#---------------------------------------------------------- - -!if !exist(nmakehlp.exe) -!if [$(cc32) -nologo nmakehlp.c -link -subsystem:console > nul] -!endif -!endif - -#---------------------------------------------------------- -# Test for compiler features -#---------------------------------------------------------- - -### test for optimizations -!if [nmakehlp -c -Ot] -!message *** Compiler has 'Optimizations' -OPTIMIZING = 1 -!else -!message *** Compiler does not have 'Optimizations' -OPTIMIZING = 0 -!endif - -OPTIMIZATIONS = - -!if [nmakehlp -c -Ot] -OPTIMIZATIONS = $(OPTIMIZATIONS) -Ot -!endif - -!if [nmakehlp -c -Oi] -OPTIMIZATIONS = $(OPTIMIZATIONS) -Oi -!endif - +################################################################ +# 4. Build the nmakehlp program +# This is a helper app we need to overcome nmake's limiting +# environment. We will call out to it to get various bits of +# information about supported compiler options etc. +# +# Tcl itself will always use the nmakehlp.c program which is +# in its own source. This is the "master" copy and kept updated. +# +# Extensions built against an installed Tcl will use the installed +# copy of Tcl's nmakehlp.c if there is one and their own version +# otherwise. In the latter case, they would also be using their own +# rules.vc. Note that older versions of Tcl do not install nmakehlp.c +# or rules.vc. +# +# Extensions built against Tcl sources will use the one from the Tcl source. +# +# When building an extension using a sufficiently new version of Tcl, +# rules-ext.vc will define NMAKEHLPC appropriately to point to the +# copy of nmakehlp.c to be used. + +!ifndef NMAKEHLPC +# Default to the one in the current directory (the extension's own nmakehlp.c) +NMAKEHLPC = nmakehlp.c + +!if !$(DOING_TCL) +!if $(TCLINSTALL) +!if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c") +NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c +!endif +!else # ! $(TCLINSTALL) +!if exist("$(_TCLDIR)\win\nmakehlp.c") +NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c +!endif +!endif # $(TCLINSTALL) +!endif # !$(DOING_TCL) + +!endif # NMAKEHLPC + +# We always build nmakehlp even if it exists since we do not know +# what source it was built from. +!if [$(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console > nul] +!endif + +################################################################ +# 5. Test for compiler features +# Visual C++ compiler options have changed over the years. Check +# which options are supported by the compiler in use. +# +# The following macros are set: +# OPTIMIZATIONS - the compiler flags to be used for optimized builds +# DEBUGFLAGS - the compiler flags to be used for debug builds +# LINKERFLAGS - Flags passed to the linker +# +# Note that these are the compiler settings *available*, not those +# that will be *used*. The latter depends on the OPTS macro settings +# which we have not yet parsed. +# +# Also note that some of the flags in OPTIMIZATIONS are not really +# related to optimization. They are placed there only for legacy reasons +# as some extensions expect them to be included in that macro. + +# -Op improves float consistency. Note only needed for older compilers +# Newer compilers do not need or support this option. !if [nmakehlp -c -Op] -OPTIMIZATIONS = $(OPTIMIZATIONS) -Op +FPOPTS = -Op !endif +# Strict floating point semantics - present in newer compilers in lieu of -Op !if [nmakehlp -c -fp:strict] -OPTIMIZATIONS = $(OPTIMIZATIONS) -fp:strict -!endif - -!if [nmakehlp -c -Gs] -OPTIMIZATIONS = $(OPTIMIZATIONS) -Gs -!endif - -!if [nmakehlp -c -GS] -OPTIMIZATIONS = $(OPTIMIZATIONS) -GS -!endif - -!if [nmakehlp -c -GL] -OPTIMIZATIONS = $(OPTIMIZATIONS) -GL -!endif - -DEBUGFLAGS = - -!if [nmakehlp -c -RTC1] -DEBUGFLAGS = $(DEBUGFLAGS) -RTC1 -!elseif [nmakehlp -c -GZ] -DEBUGFLAGS = $(DEBUGFLAGS) -GZ -!endif - -COMPILERFLAGS =-W3 /DUNICODE /D_UNICODE /D_ATL_XP_TARGETING - -# In v13 -GL and -YX are incompatible. -!if [nmakehlp -c -YX] -!if ![nmakehlp -c -GL] -OPTIMIZATIONS = $(OPTIMIZATIONS) -YX -!endif +FPOPTS = $(FPOPTS) -fp:strict !endif !if "$(MACHINE)" == "IX86" ### test for pentium errata !if [nmakehlp -c -QI0f] !message *** Compiler has 'Pentium 0x0f fix' -COMPILERFLAGS = $(COMPILERFLAGS) -QI0f +FPOPTS = $(FPOPTS) -QI0f !else !message *** Compiler does not have 'Pentium 0x0f fix' !endif !endif -!if "$(MACHINE)" == "IA64" -### test for Itanium errata -!if [nmakehlp -c -QIA64_Bx] -!message *** Compiler has 'B-stepping errata workarounds' -COMPILERFLAGS = $(COMPILERFLAGS) -QIA64_Bx +### test for optimizations +# /O2 optimization includes /Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy as per +# documentation. Note we do NOT want /Gs as that inserts a _chkstk +# stack probe at *every* function entry, not just those with more than +# a page of stack allocation resulting in a performance hit. However, +# /O2 documentation is misleading as its stack probes are simply the +# default page size locals allocation probes and not what is implied +# by an explicit /Gs option. + +OPTIMIZATIONS = $(FPOPTS) + +!if [nmakehlp -c -O2] +OPTIMIZING = 1 +OPTIMIZATIONS = $(OPTIMIZATIONS) -O2 +!else +# Legacy, really. All modern compilers support this +!message *** Compiler does not have 'Optimizations' +OPTIMIZING = 0 +!endif + +# Checks for buffer overflows in local arrays +!if [nmakehlp -c -GS] +OPTIMIZATIONS = $(OPTIMIZATIONS) -GS +!endif + +# Link time optimization. Note that this option (potentially) makes +# generated libraries only usable by the specific VC++ version that +# created it. Requires /LTCG linker option +!if [nmakehlp -c -GL] +OPTIMIZATIONS = $(OPTIMIZATIONS) -GL +CC_GL_OPT_ENABLED = 1 !else -!message *** Compiler does not have 'B-stepping errata workarounds' +# In newer compilers -GL and -YX are incompatible. +!if [nmakehlp -c -YX] +OPTIMIZATIONS = $(OPTIMIZATIONS) -YX !endif +!endif # [nmakehlp -c -GL] + +DEBUGFLAGS = $(FPOPTS) + +# Run time error checks. Not available or valid in a release, non-debug build +# RTC is for modern compilers, -GZ is legacy +!if [nmakehlp -c -RTC1] +DEBUGFLAGS = $(DEBUGFLAGS) -RTC1 +!elseif [nmakehlp -c -GZ] +DEBUGFLAGS = $(DEBUGFLAGS) -GZ !endif -# Prevents "LNK1561: entry point must be defined" error compiling from VS-IDE: +#---------------------------------------------------------------- +# Linker flags + +# LINKER_TESTFLAGS are for internal use when we call nmakehlp to test +# if the linker supports a specific option. Without these flags link will +# return "LNK1561: entry point must be defined" error compiling from VS-IDE: +# They are not passed through to the actual application / extension +# link rules. !ifndef LINKER_TESTFLAGS -LINKER_TESTFLAGS = /DLL /NOENTRY /OUT:nmhlp-out.txt -!endif - -!if "$(MACHINE)" == "IX86" -### test for -align:4096, when align:512 will do. -!if [nmakehlp -l -opt:nowin98 $(LINKER_TESTFLAGS)] -!message *** Linker has 'Win98 alignment problem' -ALIGN98_HACK = 1 -!else -!message *** Linker does not have 'Win98 alignment problem' -ALIGN98_HACK = 0 -!endif -!else -ALIGN98_HACK = 0 +LINKER_TESTFLAGS = /DLL /NOENTRY /OUT:nmakehlp.out !endif LINKERFLAGS = +# If compiler has enabled link time optimization, linker must too with -ltcg +!ifdef CC_GL_OPT_ENABLED !if [nmakehlp -l -ltcg $(LINKER_TESTFLAGS)] -LINKERFLAGS =-ltcg +LINKERFLAGS = $(LINKERFLAGS) -ltcg +!endif !endif -#---------------------------------------------------------- -# Decode the options requested. -#---------------------------------------------------------- +######################################################################## +# 6. Parse the OPTS macro to work out the requested build configuration. +# Based on this, we will construct the actual switches to be passed to the +# compiler and linker using the macros defined in the previous section. +# The following macros are defined by this section based on OPTS +# STATIC_BUILD - 0 -> Tcl is to be built as a shared library +# 1 -> build as a static library and shell +# TCL_THREADS - legacy but always 1 on Windows since winsock requires it. +# DEBUG - 1 -> debug build, 0 -> release builds +# SYMBOLS - 1 -> generate PDB's, 0 -> no PDB's +# PROFILE - 1 -> generate profiling info, 0 -> no profiling +# PGO - 1 -> profile based optimization, 0 -> no +# MSVCRT - 1 -> link to dynamic C runtime even when building static Tcl build +# 0 -> link to static C runtime for static Tcl build. +# Does not impact shared Tcl builds (STATIC_BUILD == 0) +# TCL_USE_STATIC_PACKAGES - 1 -> statically link the registry and dde extensions +# in the Tcl shell. 0 -> keep them as shared libraries +# Does not impact shared Tcl builds. +# USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation. +# 0 -> Use the non-thread allocator. +# UNCHECKED - 1 -> when doing a debug build with symbols, use the release +# C runtime, 0 -> use the debug C runtime. +# USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking +# CONFIG_CHECK - 1 -> check current build configuration against Tcl +# configuration (ignored for Tcl itself) +# Further, LINKERFLAGS are modified based on above. -!if "$(OPTS)" == "" || [nmakehlp -f "$(OPTS)" "none"] +# Default values for all the above STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 SYMBOLS = 0 PROFILE = 0 PGO = 0 MSVCRT = 1 -LOIMPACT = 0 TCL_USE_STATIC_PACKAGES = 0 USE_THREAD_ALLOC = 1 UNCHECKED = 0 +CONFIG_CHECK = 1 +!if $(DOING_TCL) +USE_STUBS = 0 !else +USE_STUBS = 1 +!endif + +# If OPTS is not empty AND does not contain "none" which turns off all OPTS +# set the above macros based on OPTS content +!if "$(OPTS)" != "" && ![nmakehlp -f "$(OPTS)" "none"] + +# OPTS are specified, parse them + !if [nmakehlp -f $(OPTS) "static"] !message *** Doing static STATIC_BUILD = 1 -!else -STATIC_BUILD = 0 !endif + +!if [nmakehlp -f $(OPTS) "nostubs"] +!message *** Not using stubs +USE_STUBS = 0 +!endif + !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] @@ -247,90 +719,281 @@ MSVCRT = 1 !else MSVCRT = 0 !endif !endif -!endif +!endif # [nmakehlp -f $(OPTS) "nomsvcrt"] + !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !else TCL_USE_STATIC_PACKAGES = 0 !endif + !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !else TCL_THREADS = 1 USE_THREAD_ALLOC= 1 !endif + !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 !else DEBUG = 0 !endif + !if [nmakehlp -f $(OPTS) "pdbs"] !message *** Doing pdbs SYMBOLS = 1 !else SYMBOLS = 0 !endif + !if [nmakehlp -f $(OPTS) "profile"] !message *** Doing profile PROFILE = 1 !else PROFILE = 0 !endif + !if [nmakehlp -f $(OPTS) "pgi"] !message *** Doing profile guided optimization instrumentation PGO = 1 !elseif [nmakehlp -f $(OPTS) "pgo"] !message *** Doing profile guided optimization PGO = 2 !else PGO = 0 !endif + !if [nmakehlp -f $(OPTS) "loimpact"] -!message *** Doing loimpact -LOIMPACT = 1 -!else -LOIMPACT = 0 +!message *** Warning: ignoring option "loimpact" - deprecated on modern Windows. !endif + +# TBD - should get rid of this option !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !endif + !if [nmakehlp -f $(OPTS) "tclalloc"] -!message *** Doing tclalloc USE_THREAD_ALLOC = 0 !endif + !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked UNCHECKED = 1 !else UNCHECKED = 0 !endif + +!if [nmakehlp -f $(OPTS) "noconfigcheck"] +CONFIG_CHECK = 1 +!else +CONFIG_CHECK = 0 !endif -#---------------------------------------------------------- +!endif # "$(OPTS)" != "" && ... parsing of OPTS + +# Set linker flags based on above + +!if $(PGO) > 1 +!if [nmakehlp -l -ltcg:pgoptimize $(LINKER_TESTFLAGS)] +LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pgoptimize +!else +MSG=^ +This compiler does not support profile guided optimization. +!error $(MSG) +!endif +!elseif $(PGO) > 0 +!if [nmakehlp -l -ltcg:pginstrument $(LINKER_TESTFLAGS)] +LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pginstrument +!else +MSG=^ +This compiler does not support profile guided optimization. +!error $(MSG) +!endif +!endif + +################################################################ +# 7. Parse the STATS macro to configure code instrumentation +# The following macros are set by this section: +# TCL_MEM_DEBUG - 1 -> enables memory allocation instrumentation +# 0 -> disables +# TCL_COMPILE_DEBUG - 1 -> enables byte compiler logging +# 0 -> disables + +# Default both are off +TCL_MEM_DEBUG = 0 +TCL_COMPILE_DEBUG = 0 + +!if "$(STATS)" != "" && ![nmakehlp -f "$(STATS)" "none"] + +!if [nmakehlp -f $(STATS) "memdbg"] +!message *** Doing memdbg +TCL_MEM_DEBUG = 1 +!else +TCL_MEM_DEBUG = 0 +!endif + +!if [nmakehlp -f $(STATS) "compdbg"] +!message *** Doing compdbg +TCL_COMPILE_DEBUG = 1 +!else +TCL_COMPILE_DEBUG = 0 +!endif + +!endif + +#################################################################### +# 8. Parse the CHECKS macro to configure additional compiler checks +# The following macros are set by this section: +# WARNINGS - compiler switches that control the warnings level +# TCL_NO_DEPRECATED - 1 -> disable support for deprecated functions +# 0 -> enable deprecated functions + +# Defaults - Permit deprecated functions and warning level 3 +TCL_NO_DEPRECATED = 0 +WARNINGS = -W3 + +!if "$(CHECKS)" != "" && ![nmakehlp -f "$(CHECKS)" "none"] + +!if [nmakehlp -f $(CHECKS) "nodep"] +!message *** Doing nodep check +TCL_NO_DEPRECATED = 1 +!endif + +!if [nmakehlp -f $(CHECKS) "fullwarn"] +!message *** Doing full warnings check +WARNINGS = -W4 +!if [nmakehlp -l -warn:3 $(LINKER_TESTFLAGS)] +LINKERFLAGS = $(LINKERFLAGS) -warn:3 +!endif +!endif + +!if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64] +!message *** Doing 64bit portability warnings +WARNINGS = $(WARNINGS) -Wp64 +!endif + +!endif + +################################################################ +# 9. Extract various version numbers +# For Tcl and Tk, version numbers are extracted from tcl.h and tk.h +# respectively. For extensions, versions are extracted from the +# configure.in or configure.ac from the TEA configuration if it +# exists, and unset otherwise. +# Sets the following macros: +# TCL_MAJOR_VERSION +# TCL_MINOR_VERSION +# TCL_PATCH_LEVEL +# TCL_VERSION +# TK_MAJOR_VERSION +# TK_MINOR_VERSION +# TK_PATCH_LEVEL +# TK_VERSION +# DOTVERSION - set as (for example) 2.5 +# VERSION - set as (for example 25) +#-------------------------------------------------------------- + +!if [echo REM = This file is generated from rules.vc > versions.vc] +!endif +!if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" TCL_MAJOR_VERSION >> versions.vc] +!endif +!if [echo TCL_MINOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] +!endif +!if [echo TCL_PATCH_LEVEL = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" TCL_PATCH_LEVEL >> versions.vc] +!endif + +!if defined(_TK_H) +!if [echo TK_MAJOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V $(_TK_H) TK_MAJOR_VERSION >> versions.vc] +!endif +!if [echo TK_MINOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc] +!endif +!if [echo TK_PATCH_LEVEL = \>> versions.vc] \ + && [nmakehlp -V $(_TK_H) TK_PATCH_LEVEL >> versions.vc] +!endif +!endif # _TK_H + +!include versions.vc + +TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) +TCL_DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +!if defined(_TK_H) +TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION) +TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) +!endif + +# Set DOTVERSION and VERSION +!if $(DOING_TCL) + +DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +VERSION = $(TCL_VERSION) + +!elseif $(DOING_TK) + +DOTVERSION = $(TK_DOTVERSION) +VERSION = $(TK_VERSION) + +!else # Doing a non-Tk extension + +# If parent makefile has not defined DOTVERSION, try to get it from TEA +# first from a configure.in file, and then from configure.ac +!ifndef DOTVERSION +!if [echo DOTVERSION = \> versions.vc] \ + || [nmakehlp -V $(ROOT)\configure.in ^[$(PROJECT)^] >> versions.vc] +!if [echo DOTVERSION = \> versions.vc] \ + || [nmakehlp -V $(ROOT)\configure.ac ^[$(PROJECT)^] >> versions.vc] +!error *** Could not figure out extension version. Please define DOTVERSION in parent makefile before including rules.vc. +!endif +!endif +!include versions.vc +!endif # DOTVERSION +VERSION = $(DOTVERSION:.=) + +!endif # $(DOING_TCL) ... etc. + +################################################################ +# 10. Construct output directory and file paths # Figure-out how to name our intermediate and output directories. -# We wouldn't want different builds to use the same .obj files -# by accident. -#---------------------------------------------------------- - -#---------------------------------------- -# Naming convention: +# In order to avoid inadvertent mixing of object files built using +# different compilers, build configurations etc., +# +# Naming convention (suffixes): # t = full thread support. -# s = static library (as opposed to an -# import library) -# g = linked to the debug enabled C -# run-time. -# x = special static build when it -# links to the dynamic C run-time. -#---------------------------------------- +# s = static library (as opposed to an import library) +# g = linked to the debug enabled C run-time. +# x = special static build when it links to the dynamic C run-time. +# +# The following macros are set in this section: +# SUFX - the suffix to use for binaries based on above naming convention +# BUILDDIRTOP - the toplevel default output directory +# is of the form {Release,Debug}[_AMD64][_COMPILERVERSION] +# TMP_DIR - directory where object files are created +# OUT_DIR - directory where output executables are created +# Both TMP_DIR and OUT_DIR are defaulted only if not defined by the +# parent makefile (or command line). The default values are +# based on BUILDDIRTOP. +# STUBPREFIX - name of the stubs library for this project +# PRJIMPLIB - output path of the generated project import library +# PRJLIBNAME - name of generated project library +# PRJLIB - output path of generated project library +# PRJSTUBLIBNAME - name of the generated project stubs library +# PRJSTUBLIB - output path of the generated project stubs library +# RESFILE - output resource file (only if not static build) + SUFX = tsgx !if $(DEBUG) BUILDDIRTOP = Debug !else @@ -379,84 +1042,221 @@ !ifndef OUT_DIR OUT_DIR = $(TMP_DIR) !endif !endif - -#---------------------------------------------------------- -# Decode the statistics requested. -#---------------------------------------------------------- - -!if "$(STATS)" == "" || [nmakehlp -f "$(STATS)" "none"] -TCL_MEM_DEBUG = 0 -TCL_COMPILE_DEBUG = 0 -!else -!if [nmakehlp -f $(STATS) "memdbg"] -!message *** Doing memdbg -TCL_MEM_DEBUG = 1 -!else -TCL_MEM_DEBUG = 0 -!endif -!if [nmakehlp -f $(STATS) "compdbg"] -!message *** Doing compdbg -TCL_COMPILE_DEBUG = 1 -!else -TCL_COMPILE_DEBUG = 0 -!endif -!endif - - -#---------------------------------------------------------- -# Decode the checks requested. -#---------------------------------------------------------- - -!if "$(CHECKS)" == "" || [nmakehlp -f "$(CHECKS)" "none"] -TCL_NO_DEPRECATED = 0 -WARNINGS = -W3 -!else -!if [nmakehlp -f $(CHECKS) "nodep"] -!message *** Doing nodep check -TCL_NO_DEPRECATED = 1 -!else -TCL_NO_DEPRECATED = 0 -!endif -!if [nmakehlp -f $(CHECKS) "fullwarn"] -!message *** Doing full warnings check -WARNINGS = -W4 -!if [nmakehlp -l -warn:3 $(LINKER_TESTFLAGS)] -LINKERFLAGS = $(LINKERFLAGS) -warn:3 -!endif -!else -WARNINGS = -W3 -!endif -!if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64] -!message *** Doing 64bit portability warnings -WARNINGS = $(WARNINGS) -Wp64 -!endif -!endif - -!if $(PGO) > 1 -!if [nmakehlp -l -ltcg:pgoptimize $(LINKER_TESTFLAGS)] -LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pgoptimize -!else -MSG=^ -This compiler does not support profile guided optimization. -!error $(MSG) -!endif -!elseif $(PGO) > 0 -!if [nmakehlp -l -ltcg:pginstrument $(LINKER_TESTFLAGS)] -LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pginstrument -!else -MSG=^ -This compiler does not support profile guided optimization. -!error $(MSG) -!endif -!endif - -#---------------------------------------------------------- -# Set our defines now armed with our options. -#---------------------------------------------------------- +# Relative paths -> absolute +!if [echo OUT_DIR = \> nmakehlp.out] \ + || [nmakehlp -Q "$(OUT_DIR)" >> nmakehlp.out] +!error *** Could not fully qualify path OUT_DIR=$(OUT_DIR) +!endif +!if [echo TMP_DIR = \>> nmakehlp.out] \ + || [nmakehlp -Q "$(TMP_DIR)" >> nmakehlp.out] +!error *** Could not fully qualify path TMP_DIR=$(TMP_DIR) +!endif +!include nmakehlp.out + +# The name of the stubs library for the project being built +STUBPREFIX = $(PROJECT)stub + +# Set up paths to various Tcl executables and libraries needed by extensions +!if $(DOING_TCL) + +TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe +TCLSH = $(OUT_DIR)\$(TCLSHNAME) +TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib +TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) +TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) + +TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib +TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) +TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" + +!else # ! $(DOING_TCL) + +!if $(TCLINSTALL) # Building against an installed Tcl + +# When building extensions, we need to locate tclsh. Depending on version +# of Tcl we are building against, this may or may not have a "t" suffix. +# Try various possibilities in turn. +TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe +!if !exist("$(TCLSH)") && $(TCL_THREADS) +TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe +!endif +!if !exist("$(TCLSH)") +TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe +!endif + +TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib +TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib +# When building extensions, may be linking against Tcl that does not add +# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. +!if !exist("$(TCLIMPLIB)") +TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib +!endif +TCL_LIBRARY = $(_TCLDIR)\lib +TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib +TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib +TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target +TCL_INCLUDES = -I"$(_TCLDIR)\include" + +!else # Building against Tcl sources + +TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe +!if !exist($(TCLSH)) && $(TCL_THREADS) +TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe +!endif +!if !exist($(TCLSH)) +TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe +!endif +TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib +TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib +# When building extensions, may be linking against Tcl that does not add +# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. +!if !exist("$(TCLIMPLIB)") +TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib +!endif +TCL_LIBRARY = $(_TCLDIR)\library +TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib +TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib +TCLTOOLSDIR = $(_TCLDIR)\tools +TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" + +!endif # TCLINSTALL + +tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)" + +!endif # $(DOING_TCL) + +# We need a tclsh that will run on the host machine as part of the build. +# IX86 runs on all architectures. +!ifndef TCLSH_NATIVE +!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" +TCLSH_NATIVE = $(TCLSH) +!else +!error You must explicitly set TCLSH_NATIVE for cross-compilation +!endif +!endif + +# Do the same for Tk and Tk extensions that require the Tk libraries +!if $(DOING_TK) || $(NEED_TK) +WISHNAMEPREFIX = wish +WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe +TKLIBNAME = $(PROJECT)$(TK_VERSION)$(SUFX).$(EXT) +TKSTUBLIBNAME = tkstub$(TK_VERSION).lib +TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib + +!if $(DOING_TK) +WISH = $(OUT_DIR)\$(WISHNAME) +TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) +TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) +TKLIB = $(OUT_DIR)\$(TKLIBNAME) +TK_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" + +!else # effectively NEED_TK + +!if $(TKINSTALL) # Building against installed Tk +WISH = $(_TKDIR)\bin\$(WISHNAME) +TKSTUBLIB = $(_TKDIR)\lib\$(TKSTUBLIBNAME) +TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) +# When building extensions, may be linking against Tk that does not add +# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. +!if !exist("$(TKIMPLIB)") +TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib +TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) +!endif +TK_INCLUDES = -I"$(_TKDIR)\include" +!else # Building against Tk sources +WISH = $(_TKDIR)\win\$(BUILDDIRTOP)\$(WISHNAME) +TKSTUBLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSTUBLIBNAME) +TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) +# When building extensions, may be linking against Tk that does not add +# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. +!if !exist("$(TKIMPLIB)") +TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib +TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) +!endif +TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib" +!endif # TKINSTALL +tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" + +!endif # $(DOING_TK) +!endif # $(DOING_TK) || $(NEED_TK) + +# Various output paths +PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX:t=).lib +PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX:t=).$(EXT) +PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) + +PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib +PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME) + +# If extension parent makefile has not defined a resource definition file, +# we will generate one from standard template. +!if !$(DOING_TCL) && !$(DOING_TK) && !$(STATIC_BUILD) +!ifdef RCFILE +RESFILE = $(TMP_DIR)\$(RCFILE:.rc=.res) +!else +RESFILE = $(TMP_DIR)\$(PROJECT).res +!endif +!endif + +################################################################### +# 11. Construct the paths for the installation directories +# The following macros get defined in this section: +# LIB_INSTALL_DIR - where libraries should be installed +# BIN_INSTALL_DIR - where the executables should be installed +# DOC_INSTALL_DIR - where documentation should be installed +# SCRIPT_INSTALL_DIR - where scripts should be installed +# INCLUDE_INSTALL_DIR - where C include files should be installed +# DEMO_INSTALL_DIR - where demos should be installed +# PRJ_INSTALL_DIR - where package will be installed (not set for tcl and tk) + +!if $(DOING_TCL) || $(DOING_TK) +LIB_INSTALL_DIR = $(_INSTALLDIR)\lib +BIN_INSTALL_DIR = $(_INSTALLDIR)\bin +DOC_INSTALL_DIR = $(_INSTALLDIR)\doc +!if $(DOING_TCL) +SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +!else # DOING_TK +SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) +!endif +DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos +INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include + +!else # extension other than Tk + +PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION) +LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR) +BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR) +DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR) +SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR) +DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos +INCLUDE_INSTALL_DIR = $(_TCLDIR)\include + +!endif + +################################################################### +# 12. Set up actual options to be passed to the compiler and linker +# Now we have all the information we need, set up the actual flags and +# options that we will pass to the compiler and linker. The main +# makefile should use these in combination with whatever other flags +# and switches are specific to it. +# The following macros are defined, names are for historical compatibility: +# OPTDEFINES - /Dxxx C macro flags based on user-specified OPTS +# COMPILERFLAGS - /Dxxx C macro flags independent of any configuration opttions +# crt - Compiler switch that selects the appropriate C runtime +# cdebug - Compiler switches related to debug AND optimizations +# cwarn - Compiler switches that set warning levels +# cflags - complete compiler switches (subsumes cdebug and cwarn) +# ldebug - Linker switches controlling debug information and optimization +# lflags - complete linker switches (subsumes ldebug) except subsystem type +# dlllflags - complete linker switches to build DLLs (subsumes lflags) +# conlflags - complete linker switches for console program (subsumes lflags) +# guilflags - complete linker switches for GUI program (subsumes lflags) +# baselibs - minimum Windows libraries required. Parent makefile can +# define PRJ_LIBS before including rules.rc if additional libs are needed OPTDEFINES = -DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) -DSTDC_HEADERS !if $(TCL_MEM_DEBUG) OPTDEFINES = $(OPTDEFINES) -DTCL_MEM_DEBUG @@ -475,234 +1275,466 @@ !endif !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) -DTCL_NO_DEPRECATED !endif +!if $(USE_STUBS) +# Note we do not define USE_TCL_STUBS even when building tk since some +# test targets in tk do not use stubs +!if ! $(DOING_TCL) +USE_STUBS_DEFS = -DUSE_TCL_STUBS -DUSE_TCLOO_STUBS +!if $(NEED_TK) +USE_STUBS_DEFS = $(USE_STUBS_DEFS) -DUSE_TK_STUBS +!endif +!endif +!endif # USE_STUBS + !if !$(DEBUG) OPTDEFINES = $(OPTDEFINES) -DNDEBUG !if $(OPTIMIZING) OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED !endif !endif !if $(PROFILE) OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED !endif -!if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" +!if "$(MACHINE)" == "AMD64" OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 OPTDEFINES = $(OPTDEFINES) -DNO_STRTOI64 !endif -#---------------------------------------------------------- -# Locate the Tcl headers to build against -#---------------------------------------------------------- - -!if "$(PROJECT)" == "tcl" - -_TCL_H = ..\generic\tcl.h - -!else - -# If INSTALLDIR set to tcl root dir then reset to the lib dir. -!if exist("$(_INSTALLDIR)\include\tcl.h") -_INSTALLDIR=$(_INSTALLDIR)\lib -!endif - -!if !defined(TCLDIR) -!if exist("$(_INSTALLDIR)\..\include\tcl.h") -TCLINSTALL = 1 -_TCLDIR = $(_INSTALLDIR)\.. -_TCL_H = $(_INSTALLDIR)\..\include\tcl.h -TCLDIR = $(_INSTALLDIR)\.. -!else -MSG=^ -Failed to find tcl.h. Set the TCLDIR macro. -!error $(MSG) -!endif -!else -_TCLDIR = $(TCLDIR:/=\) -!if exist("$(_TCLDIR)\include\tcl.h") -TCLINSTALL = 1 -_TCL_H = $(_TCLDIR)\include\tcl.h -!elseif exist("$(_TCLDIR)\generic\tcl.h") -TCLINSTALL = 0 -_TCL_H = $(_TCLDIR)\generic\tcl.h -!else -MSG =^ -Failed to find tcl.h. The TCLDIR macro does not appear correct. -!error $(MSG) -!endif -!endif -!endif - -#-------------------------------------------------------------- -# Extract various version numbers from tcl headers -# The generated file is then included in the makefile. -#-------------------------------------------------------------- - -!if [echo REM = This file is generated from rules.vc > versions.vc] -!endif -!if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V "$(_TCL_H)" TCL_MAJOR_VERSION >> versions.vc] -!endif -!if [echo TCL_MINOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] -!endif -!if [echo TCL_PATCH_LEVEL = \>> versions.vc] \ - && [nmakehlp -V "$(_TCL_H)" TCL_PATCH_LEVEL >> versions.vc] -!endif - -# If building the tcl core then we need additional package versions -!if "$(PROJECT)" == "tcl" -!if [echo PKG_HTTP_VER = \>> versions.vc] \ - && [nmakehlp -V ..\library\http\pkgIndex.tcl http >> versions.vc] -!endif -!if [echo PKG_TCLTEST_VER = \>> versions.vc] \ - && [nmakehlp -V ..\library\tcltest\pkgIndex.tcl tcltest >> versions.vc] -!endif -!if [echo PKG_MSGCAT_VER = \>> versions.vc] \ - && [nmakehlp -V ..\library\msgcat\pkgIndex.tcl msgcat >> versions.vc] -!endif -!if [echo PKG_PLATFORM_VER = \>> versions.vc] \ - && [nmakehlp -V ..\library\platform\pkgIndex.tcl "platform " >> versions.vc] -!endif -!if [echo PKG_SHELL_VER = \>> versions.vc] \ - && [nmakehlp -V ..\library\platform\pkgIndex.tcl "platform::shell" >> versions.vc] -!endif -!if [echo PKG_DDE_VER = \>> versions.vc] \ - && [nmakehlp -V ..\library\dde\pkgIndex.tcl "dde " >> versions.vc] -!endif -!if [echo PKG_REG_VER =\>> versions.vc] \ - && [nmakehlp -V ..\library\reg\pkgIndex.tcl registry >> versions.vc] -!endif -!endif - -!include versions.vc - -#-------------------------------------------------------------- -# Setup tcl version dependent stuff headers -#-------------------------------------------------------------- - -!if "$(PROJECT)" != "tcl" - -TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) - -!if $(TCLINSTALL) -TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe" -!if !exist($(TCLSH)) && $(TCL_THREADS) -TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe" -!endif -TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib" -TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib" -TCL_LIBRARY = $(_TCLDIR)\lib -TCLREGLIB = "$(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib" -COFFBASE = \must\have\tcl\sources\to\build\this\target -TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target -TCL_INCLUDES = -I"$(_TCLDIR)\include" -!else -TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe" -!if !exist($(TCLSH)) && $(TCL_THREADS) -TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe" -!endif -TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib" -TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib" -TCL_LIBRARY = $(_TCLDIR)\library -TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib" -COFFBASE = "$(_TCLDIR)\win\coffbase.txt" -TCLTOOLSDIR = $(_TCLDIR)\tools -TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" -!endif - -!endif - -#------------------------------------------------------------------------- -# Locate the Tk headers to build against -#------------------------------------------------------------------------- - -!if "$(PROJECT)" == "tk" -_TK_H = ..\generic\tk.h -_INSTALLDIR = $(_INSTALLDIR)\.. -!endif - -!ifdef PROJECT_REQUIRES_TK -!if !defined(TKDIR) -!if exist("$(_INSTALLDIR)\..\include\tk.h") -TKINSTALL = 1 -_TKDIR = $(_INSTALLDIR)\.. -_TK_H = $(_TKDIR)\include\tk.h -TKDIR = $(_TKDIR) -!elseif exist("$(_TCLDIR)\include\tk.h") -TKINSTALL = 1 -_TKDIR = $(_TCLDIR) -_TK_H = $(_TKDIR)\include\tk.h -TKDIR = $(_TKDIR) -!endif -!else -_TKDIR = $(TKDIR:/=\) -!if exist("$(_TKDIR)\include\tk.h") -TKINSTALL = 1 -_TK_H = $(_TKDIR)\include\tk.h -!elseif exist("$(_TKDIR)\generic\tk.h") -TKINSTALL = 0 -_TK_H = $(_TKDIR)\generic\tk.h -!else -MSG =^ -Failed to find tk.h. The TKDIR macro does not appear correct. -!error $(MSG) -!endif -!endif -!endif - -#------------------------------------------------------------------------- -# Extract Tk version numbers -#------------------------------------------------------------------------- - -!if defined(PROJECT_REQUIRES_TK) || "$(PROJECT)" == "tk" - -!if [echo TK_MAJOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V $(_TK_H) TK_MAJOR_VERSION >> versions.vc] -!endif -!if [echo TK_MINOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc] -!endif -!if [echo TK_PATCH_LEVEL = \>> versions.vc] \ - && [nmakehlp -V $(_TK_H) TK_PATCH_LEVEL >> versions.vc] -!endif - -!include versions.vc - -TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) -TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION) - -!if "$(PROJECT)" != "tk" -!if $(TKINSTALL) -WISH = "$(_TKDIR)\bin\wish$(TK_VERSION)$(SUFX).exe" -TKSTUBLIB = "$(_TKDIR)\lib\tkstub$(TK_VERSION).lib" -TKIMPLIB = "$(_TKDIR)\lib\tk$(TK_VERSION)$(SUFX).lib" -TK_INCLUDES = -I"$(_TKDIR)\include" -!else -WISH = "$(_TKDIR)\win\$(BUILDDIRTOP)\wish$(TCL_VERSION)$(SUFX).exe" -TKSTUBLIB = "$(_TKDIR)\win\$(BUILDDIRTOP)\tkstub$(TCL_VERSION).lib" -TKIMPLIB = "$(_TKDIR)\win\$(BUILDDIRTOP)\tk$(TCL_VERSION)$(SUFX).lib" -TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib" -!endif -!endif - -!endif +# _ATL_XP_TARGETING - Newer SDK's need this to build for XP +COMPILERFLAGS = /D_ATL_XP_TARGETING + +# Following is primarily for the benefit of extensions. Tcl 8.5 builds +# Tcl without /DUNICODE, while 8.6 builds with it defined. When building +# an extension, it is advisable (but not mandated) to use the same Windows +# API as the Tcl build. This is accordingly defaulted below. A particular +# extension can override this by pre-definining USE_WIDECHAR_API. +!ifndef USE_WIDECHAR_API +!if $(TCL_VERSION) > 85 +USE_WIDECHAR_API = 1 +!else +USE_WIDECHAR_API = 0 +!endif +!endif + +!if $(USE_WIDECHAR_API) +COMPILERFLAGS = $(COMPILERFLAGS) /DUNICODE /D_UNICODE +!endif + +# Like the TEA system only set this non empty for non-Tk extensions +# Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME +# so we pass both +!if !$(DOING_TCL) && !$(DOING_TK) +PKGNAMEFLAGS = -DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + -DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + -DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ + -DMODULE_SCOPE=extern +!endif + +# crt picks the C run time based on selected OPTS +!if $(MSVCRT) +!if $(DEBUG) && !$(UNCHECKED) +crt = -MDd +!else +crt = -MD +!endif +!else +!if $(DEBUG) && !$(UNCHECKED) +crt = -MTd +!else +crt = -MT +!endif +!endif + +# cdebug includes compiler options for debugging as well as optimization. +!if $(DEBUG) + +# In debugging mode, optimizations need to be disabled +cdebug = -Zi -Od $(DEBUGFLAGS) + +!else + +cdebug = $(OPTIMIZATIONS) +!if $(SYMBOLS) +cdebug = $(cdebug) -Zi +!endif + +!endif # $(DEBUG) + +# cwarn includes default warning levels. +cwarn = $(WARNINGS) + +!if "$(MACHINE)" == "AMD64" +# Disable pointer<->int warnings related to cast between different sizes +# There are a gadzillion of these due to use of ClientData and +# clutter up compiler +# output increasing chance of a real warning getting lost. So disable them. +# Eventually some day, Tcl will be 64-bit clean. +cwarn = $(cwarn) -wd4311 -wd4312 +!endif + +### Common compiler options that are architecture specific +!if "$(MACHINE)" == "ARM" +carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE +!else +carch = +!endif + +!if $(DEBUG) +# Turn warnings into errors +cwarn = $(cwarn) -WX +!endif + +INCLUDES = $(TCL_INCLUDES) $(TK_INCLUDES) $(PRJ_INCLUDES) +!if !$(DOING_TCL) && !$(DOING_TK) +INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WINDIR)" -I"$(COMPATDIR)" +!endif + +# These flags are defined roughly in the order of the pre-reform +# rules.vc/makefile.vc to help visually compare that the pre- and +# post-reform build logs + +# cflags contains generic flags used for building practically all object files +cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ $(cdebug) + +# appcflags contains $(cflags) and flags for building the application +# object files (e.g. tclsh, or wish) pkgcflags contains $(cflags) plus +# flags used for building shared object files The two differ in the +# BUILD_$(PROJECT) macro which should be defined only for the shared +# library *implementation* and not for its caller interface + +appcflags = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) $(USE_STUBS_DEFS) +appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) +pkgcflags = $(appcflags) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT) +pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT) + +# stubscflags contains $(cflags) plus flags used for building a stubs +# library for the package. Note: -DSTATIC_BUILD is defined in +# $(OPTDEFINES) only if the OPTS configuration indicates a static +# library. However the stubs library is ALWAYS static hence included +# here irrespective of the OPTS setting. +# +# TBD - tclvfs has a comment that stubs libs should not be compiled with -GL +# without stating why. Tcl itself compiled stubs libs with this flag. +# so we do not remove it from cflags. -GL may prevent extensions +# compiled with one VC version to fail to link against stubs library +# compiled with another VC version. Check for this and fix accordingly. +stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl -DSTATIC_BUILD $(INCLUDES) + +# Link flags + +!if $(DEBUG) +ldebug = -debug -debugtype:cv +!else +ldebug = -release -opt:ref -opt:icf,3 +!if $(SYMBOLS) +ldebug = $(ldebug) -debug -debugtype:cv +!endif +!endif + +# Note: Profiling is currently only possible with the Visual Studio Enterprise +!if $(PROFILE) +ldebug= $(ldebug) -profile +!endif + +### Declarations common to all linker versions +lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) + +!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 +lflags = $(lflags) -nodefaultlib:libucrt.lib +!endif + +dlllflags = $(lflags) -dll +conlflags = $(lflags) -subsystem:console +guilflags = $(lflags) -subsystem:windows + +# Libraries that are required for every image. +# Extensions should define any additional libraries with $(PRJ_LIBS) +winlibs = kernel32.lib advapi32.lib + +!if $(NEED_TK) +winlibs = $(winlibs) gdi32.lib user32.lib uxtheme.lib +!endif + +# Avoid 'unresolved external symbol __security_cookie' errors. +# c.f. http://support.microsoft.com/?id=894573 +!if "$(MACHINE)" == "AMD64" +!if $(VCVERSION) > 1399 && $(VCVERSION) < 1500 +winlibs = $(winlibs) bufferoverflowU.lib +!endif +!endif + +baselibs = $(winlibs) $(PRJ_LIBS) + +!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 +baselibs = $(baselibs) ucrt.lib +!endif + +################################################################ +# 13. Define standard commands, common make targets and implicit rules + +CCPKGCMD = $(cc32) $(pkgcflags) -Fo$(TMP_DIR)^\ +CCAPPCMD = $(cc32) $(appcflags) -Fo$(TMP_DIR)^\ +CCSTUBSCMD = $(cc32) $(stubscflags) -Fo$(TMP_DIR)^\ + +LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@ +DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) + +CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) +GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) +RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ + $(TCL_INCLUDES) \ + -DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ + -DCOMMAVERSION=$(DOTVERSION:.=,),0 \ + -DDOTVERSION=\"$(DOTVERSION)\" \ + -DVERSION=\"$(VERSION)\" \ + -DSUFX=\"$(SUFX:t=)\" \ + -DPROJECT=\"$(PROJECT)\" \ + -DPRJLIBNAME=\"$(PRJLIBNAME)\" + +!ifndef DEFAULT_BUILD_TARGET +DEFAULT_BUILD_TARGET = $(PROJECT) +!endif + +default-target: $(DEFAULT_BUILD_TARGET) + +default-pkgindex: + @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ + [list load [file join $$dir $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl + +default-pkgindex-tea: + @if exist $(ROOT)\pkgIndex.tcl.in nmakehlp -s << $(ROOT)\pkgIndex.tcl.in > $(OUT_DIR)\pkgIndex.tcl +@PACKAGE_VERSION@ $(DOTVERSION) +@PACKAGE_NAME@ $(PRJ_PACKAGE_TCLNAME) +@PACKAGE_TCLNAME@ $(PRJ_PACKAGE_TCLNAME) +@PKG_LIB_FILE@ $(PRJLIBNAME) +<< + + +default-install: default-install-binaries default-install-libraries + +default-install-binaries: $(PRJLIB) + @echo Installing binaries to '$(SCRIPT_INSTALL_DIR)' + @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" + @$(CPY) $(PRJLIB) "$(SCRIPT_INSTALL_DIR)" >NUL + +default-install-libraries: $(OUT_DIR)\pkgIndex.tcl + @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)' + @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" + @echo Installing package index in '$(SCRIPT_INSTALL_DIR)' + @$(CPY) $(OUT_DIR)\pkgIndex.tcl $(SCRIPT_INSTALL_DIR) + +default-install-stubs: + @echo Installing stubs library to '$(SCRIPT_INSTALL_DIR)' + @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" + @$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL + +default-install-docs-html: + @echo Installing documentation files to '$(DOC_INSTALL_DIR)' + @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" + @if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.html" "$(DOCDIR)\*.css" "$(DOCDIR)\*.png") do @$(COPY) %f "$(DOC_INSTALL_DIR)" + +default-install-docs-n: + @echo Installing documentation files to '$(DOC_INSTALL_DIR)' + @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" + @if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.n") do @$(COPY) %f "$(DOC_INSTALL_DIR)" + +default-install-demos: + @echo Installing demos to '$(DEMO_INSTALL_DIR)' + @if not exist "$(DEMO_INSTALL_DIR)" mkdir "$(DEMO_INSTALL_DIR)" + @if exist $(DEMODIR) $(CPYDIR) "$(DEMODIR)" "$(DEMO_INSTALL_DIR)" + +default-clean: + @echo Cleaning $(TMP_DIR)\* ... + @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) + @echo Cleaning $(WINDIR)\nmakehlp.obj, nmakehlp.exe ... + @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj + @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe + @if exist $(WINDIR)\nmakehlp.out del $(WINDIR)\nmakehlp.out + @echo Cleaning $(WINDIR)\nmhlp-out.txt ... + @if exist $(WINDIR)\nmhlp-out.txt del $(WINDIR)\nmhlp-out.txt + @echo Cleaning $(WINDIR)\_junk.pch ... + @if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch + @echo Cleaning $(WINDIR)\vercl.x, vercl.i ... + @if exist $(WINDIR)\vercl.x del $(WINDIR)\vercl.x + @if exist $(WINDIR)\vercl.i del $(WINDIR)\vercl.i + @echo Cleaning $(WINDIR)\versions.vc, version.vc ... + @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc + @if exist $(WINDIR)\version.vc del $(WINDIR)\version.vc + +default-hose: default-clean + @echo Hosing $(OUT_DIR)\* ... + @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) + +# Only for backward compatibility +default-distclean: default-hose + +default-setup: + @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) + @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) + +!if "$(TESTPAT)" != "" +TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) +!endif + +default-test: default-setup $(PROJECT) + @set TCLLIBPATH=$(OUT_DIR:\=/) + @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)" + cd "$(TESTDIR)" && $(DEBUGGER) $(TCLSH) all.tcl $(TESTFLAGS) + +default-shell: default-setup $(PROJECT) + @set TCLLIBPATH=$(OUT_DIR:\=/) + @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)" + $(DEBUGGER) $(TCLSH) + +# Generation of Windows version resource +!ifdef RCFILE + +# Note: don't use $** in below rule because there may be other dependencies +# and only the "master" rc must be passed to the resource compiler +$(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc + $(RESCMD) $(RCDIR)\$(PROJECT).rc + +!else + +# If parent makefile has not defined a resource definition file, +# we will generate one from standard template. +$(TMP_DIR)\$(PROJECT).res: $(TMP_DIR)\$(PROJECT).rc + +$(TMP_DIR)\$(PROJECT).rc: + @$(COPY) << $(TMP_DIR)\$(PROJECT).rc +#include + +VS_VERSION_INFO VERSIONINFO + FILEVERSION COMMAVERSION + PRODUCTVERSION COMMAVERSION + FILEFLAGSMASK 0x3fL +#ifdef DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0x0L +#endif + FILEOS VOS_NT_WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tcl extension " PROJECT + VALUE "OriginalFilename", PRJLIBNAME + VALUE "FileVersion", DOTVERSION + VALUE "ProductName", "Package " PROJECT " for Tcl" + VALUE "ProductVersion", DOTVERSION + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + +<< + +!endif # ifdef RCFILE + +!ifndef DISABLE_IMPLICIT_RULES +DISABLE_IMPLICIT_RULES = 0 +!endif + +!if !$(DISABLE_IMPLICIT_RULES) +# Implicit rule definitions - only for building library objects. For stubs and +# main application, the master makefile should define explicit rules. + +{$(ROOT)}.c{$(TMP_DIR)}.obj:: + $(CCPKGCMD) @<< +$< +<< + +{$(WINDIR)}.c{$(TMP_DIR)}.obj:: + $(CCPKGCMD) @<< +$< +<< + +{$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: + $(CCPKGCMD) @<< +$< +<< + +{$(COMPATDIR)}.c{$(TMP_DIR)}.obj:: + $(CCPKGCMD) @<< +$< +<< + +{$(RCDIR)}.rc{$(TMP_DIR)}.res: + $(RESCMD) $< + +{$(WINDIR)}.rc{$(TMP_DIR)}.res: + $(RESCMD) $< + +{$(TMP_DIR)}.rc{$(TMP_DIR)}.res: + $(RESCMD) $< + +.SUFFIXES: +.SUFFIXES:.c .rc + +!endif + +################################################################ +# 14. Sanity check selected options against Tcl build options +# When building an extension, certain configuration options should +# match the ones used when Tcl was built. Here we check and +# warn on a mismatch. +!if ! $(DOING_TCL) + +!if $(TCLINSTALL) # Building against an installed Tcl +!if exist("$(_TCLDIR)\lib\nmake\tcl.nmake") +TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake" +!endif +!else # ! $(TCLINSTALL) - building against Tcl source +!if exist("$(OUT_DIR)\tcl.nmake") +TCLNMAKECONFIG = "$(OUT_DIR)\tcl.nmake" +!endif +!endif # TCLINSTALL + +!if $(CONFIG_CHECK) +!ifdef TCLNMAKECONFIG +!include $(TCLNMAKECONFIG) + +!if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)" +!error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)). +!endif +!if defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC) +!message WARNING: Value of USE_THREAD_ALLOC ($(USE_THREAD_ALLOC)) does not match its Tcl core value ($(CORE_USE_THREAD_ALLOC)). +!endif +!if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG) +!message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)). +!endif +!endif + +!endif # TCLNMAKECONFIG + +!endif # ! $(DOING_TCL) + #---------------------------------------------------------- # Display stats being used. #---------------------------------------------------------- +!if !$(DOING_TCL) +!message *** Building against Tcl at '$(_TCLDIR)' +!endif +!if !$(DOING_TK) && $(NEED_TK) +!message *** Building against Tk at '$(_TKDIR)' +!endif !message *** Intermediate directory will be '$(TMP_DIR)' !message *** Output directory will be '$(OUT_DIR)' +!message *** Installation, if selected, will be in '$(_INSTALLDIR)' !message *** Suffix for binaries will be '$(SUFX)' -!message *** Optional defines are '$(OPTDEFINES)' -!message *** Compiler version $(VCVER). Target machine is $(MACHINE) -!message *** Host architecture is $(NATIVE_ARCH) -!message *** Compiler options '$(COMPILERFLAGS) $(OPTIMIZATIONS) $(DEBUGFLAGS) $(WARNINGS)' -!message *** Link options '$(LINKERFLAGS)' +!message *** Compiler version $(VCVER). Target $(MACHINE), host $(NATIVE_ARCH). -!endif +!endif # ifdef _RULES_VC ADDED win/targets.vc Index: win/targets.vc ================================================================== --- /dev/null +++ win/targets.vc @@ -0,0 +1,98 @@ +#------------------------------------------------------------- -*- makefile -*- +# targets.vc -- +# +# Part of the nmake based build system for Tcl and its extensions. +# This file defines some standard targets for the convenience of extensions +# and can be optionally included by the extension makefile. +# See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for docs. + +$(PROJECT): setup pkgindex $(PRJLIB) + +!ifdef PRJ_STUBOBJS +$(PROJECT): $(PRJSTUBLIB) +$(PRJSTUBLIB): $(PRJ_STUBOBJS) + $(LIBCMD) $** + +$(PRJ_STUBOBJS): + $(CCSTUBSCMD) %s +!endif # PRJ_STUBOBJS + +!ifdef PRJ_MANIFEST +$(PROJECT): $(PRJLIB).manifest +$(PRJLIB).manifest: $(PRJ_MANIFEST) + @nmakehlp -s << $** >$@ +@MACHINE@ $(MACHINE:IX86=X86) +<< +!endif + +!if "$(PROJECT)" != "tcl" && "$(PROJECT)" != "tk" +$(PRJLIB): $(PRJ_OBJS) $(RESFILE) +!if $(STATIC_BUILD) + $(LIBCMD) $** +!else + $(DLLCMD) $** + $(_VC_MANIFEST_EMBED_DLL) +!endif + -@del $*.exp +!endif + +!if "$(PRJ_HEADERS)" != "" && "$(PRJ_OBJS)" != "" +$(PRJ_OBJS): $(PRJ_HEADERS) +!endif + +# If parent makefile has defined stub objects, add their installation +# to the default install +!if "$(PRJ_STUBOBJS)" != "" +default-install: default-install-stubs +!endif + +# Unlike the other default targets, these cannot be in rules.vc because +# the executed command depends on existence of macro PRJ_HEADERS_PUBLIC +# that the parent makefile will not define until after including rules-ext.vc +!if "$(PRJ_HEADERS_PUBLIC)" != "" +default-install: default-install-headers +default-install-headers: + @echo Installing headers to '$(INCLUDE_INSTALL_DIR)' + @for %f in ($(PRJ_HEADERS_PUBLIC)) do @$(COPY) %f "$(INCLUDE_INSTALL_DIR)" +!endif + +!if "$(DISABLE_STANDARD_TARGETS)" == "" +DISABLE_STANDARD_TARGETS = 0 +!endif + +!if "$(DISABLE_TARGET_setup)" == "" +DISABLE_TARGET_setup = 0 +!endif +!if "$(DISABLE_TARGET_install)" == "" +DISABLE_TARGET_install = 0 +!endif +!if "$(DISABLE_TARGET_clean)" == "" +DISABLE_TARGET_clean = 0 +!endif +!if "$(DISABLE_TARGET_test)" == "" +DISABLE_TARGET_test = 0 +!endif +!if "$(DISABLE_TARGET_shell)" == "" +DISABLE_TARGET_shell = 0 +!endif + +!if !$(DISABLE_STANDARD_TARGETS) +!if !$(DISABLE_TARGET_setup) +setup: default-setup +!endif +!if !$(DISABLE_TARGET_install) +install: default-install +!endif +!if !$(DISABLE_TARGET_clean) +clean: default-clean +realclean: hose +hose: default-hose +distclean: realclean default-distclean +!endif +!if !$(DISABLE_TARGET_test) +test: default-test +!endif +!if !$(DISABLE_TARGET_shell) +shell: default-shell +!endif +!endif # DISABLE_STANDARD_TARGETS Index: win/tcl.dsp ================================================================== --- win/tcl.dsp +++ win/tcl.dsp @@ -148,14 +148,10 @@ # End Source File # Begin Source File SOURCE=..\compat\fixstrtod.c # End Source File -# Begin Source File - -SOURCE=..\compat\float.h -# End Source File # Begin Source File SOURCE=..\compat\gettod.c # End Source File # Begin Source File Index: win/tcl.hpj.in ================================================================== --- win/tcl.hpj.in +++ win/tcl.hpj.in @@ -3,13 +3,13 @@ [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual -CNT=tcl90.cnt +CNT=tcl87.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl90.hlp +HLP=tcl87.hlp [FILES] tcl.rtf [WINDOWS] Index: win/tcl.m4 ================================================================== --- win/tcl.m4 +++ win/tcl.m4 @@ -542,21 +542,10 @@ AC_MSG_CHECKING([if 64bit support is requested]) AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable)], [do64bit=$enableval], [do64bit=no]) AC_MSG_RESULT($do64bit) - # Cross-compiling options for Windows/CE builds - - AC_MSG_CHECKING([if Windows/CE build is requested]) - AC_ARG_ENABLE(wince,[ --enable-wince enable Win/CE support (where applicable)], [doWince=$enableval], [doWince=no]) - AC_MSG_RESULT($doWince) - - AC_MSG_CHECKING([for Windows/CE celib directory]) - AC_ARG_WITH(celib,[ --with-celib=DIR use Windows/CE support library from DIR], - CELIB_DIR=$withval, CELIB_DIR=NO_CELIB) - AC_MSG_RESULT([$CELIB_DIR]) - # Set some defaults (may get changed below) EXTRA_CFLAGS="" AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden]) AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo) @@ -869,102 +858,11 @@ CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="${lflags} -nologo" LINKBIN="link" fi - if test "$doWince" != "no" ; then - # Set defaults for common evc4/PPC2003 setup - # Currently Tcl requires 300+, possibly 420+ for sockets - CEVERSION=420; # could be 211 300 301 400 420 ... - TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... - ARCH=ARM; # could be ARM MIPS X86EM ... - PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" - if test "$doWince" != "yes"; then - # If !yes then the user specified something - # Reset ARCH to allow user to skip specifying it - ARCH= - eval `echo $doWince | awk -F "," '{ \ - if (length([$]1)) { printf "CEVERSION=\"%s\"\n", [$]1; \ - if ([$]1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ - if (length([$]2)) { printf "TARGETCPU=\"%s\"\n", toupper([$]2) }; \ - if (length([$]3)) { printf "ARCH=\"%s\"\n", toupper([$]3) }; \ - if (length([$]4)) { printf "PLATFORM=\"%s\"\n", [$]4 }; \ - }'` - if test "x${ARCH}" = "x" ; then - ARCH=$TARGETCPU; - fi - fi - OSVERSION=WCE$CEVERSION; - if test "x${WCEROOT}" = "x" ; then - WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" - if test ! -d "${WCEROOT}" ; then - WCEROOT="C:/Program Files/Microsoft eMbedded Tools" - fi - fi - if test "x${SDKROOT}" = "x" ; then - SDKROOT="C:/Program Files/Windows CE Tools" - if test ! -d "${SDKROOT}" ; then - SDKROOT="C:/Windows CE Tools" - fi - fi - # The space-based-path will work for the Makefile, but will - # not work if AC_TRY_COMPILE is called. - WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` - SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` - CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` - if test ! -d "${CELIB_DIR}/inc"; then - AC_MSG_ERROR([Invalid celib directory "${CELIB_DIR}"]) - fi - if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"\ - -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then - AC_MSG_ERROR([could not find PocketPC SDK or target compiler to enable WinCE mode [$CEVERSION,$TARGETCPU,$ARCH,$PLATFORM]]) - else - CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" - if test -d "${CEINCLUDE}/${TARGETCPU}" ; then - CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" - fi - CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" - fi - fi - - if test "$doWince" != "no" ; then - CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" - if test "${TARGETCPU}" = "X86"; then - CC="${CEBINROOT}/cl.exe" - else - CC="${CEBINROOT}/cl${ARCH}.exe" - fi - CC="\"${CC}\" -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" - RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" - arch=`echo ${ARCH} | awk '{print tolower([$]0)}'` - defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _DLL _WINDOWS" - for i in $defs ; do - AC_DEFINE_UNQUOTED($i) - done -# if test "${ARCH}" = "X86EM"; then -# AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION) -# fi - AC_DEFINE_UNQUOTED(_WIN32_WCE, $CEVERSION) - AC_DEFINE_UNQUOTED(UNDER_CE, $CEVERSION) - CFLAGS_DEBUG="-nologo -Zi -Od" - CFLAGS_OPTIMIZE="-nologo -O2" - lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` - lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" - LINKBIN="\"${CEBINROOT}/link.exe\"" - AC_SUBST(CELIB_DIR) - if test "${CEVERSION}" -lt 400 ; then - LIBS="coredll.lib corelibc.lib winsock.lib" - else - LIBS="coredll.lib corelibc.lib ws2.lib" - fi - # celib currently stuck at wce300 status - #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib" - LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\"" - LIBS_GUI="commctrl.lib commdlg.lib" - else - LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" - fi + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" SHLIB_LD_LIBS='${LIBS}' # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" @@ -991,11 +889,11 @@ CC_OBJNAME="-Fo\[$]@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\"" # Specify linker flags depending on the type of app being # built -- Console vs. Window. - if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then + if test "${TARGETCPU}" != "X86"; then LDFLAGS_CONSOLE="-link ${lflags}" LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} else LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" @@ -1124,17 +1022,17 @@ # Defines the following vars: # TCL_BIN_DIR Full path to the tcl build dir. #------------------------------------------------------------------------ AC_DEFUN([SC_WITH_TCL], [ - if test -d ../../tcl9.0$1/win; then - TCL_BIN_DEFAULT=../../tcl9.0$1/win + if test -d ../../tcl8.7$1/win; then + TCL_BIN_DEFAULT=../../tcl8.7$1/win else - TCL_BIN_DEFAULT=../../tcl9.0/win + TCL_BIN_DEFAULT=../../tcl8.7/win fi - AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 9.0 binaries from DIR], + AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.7 binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DEFAULT; pwd`) if test ! -d $TCL_BIN_DIR; then AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist) fi if test ! -f $TCL_BIN_DIR/Makefile; then Index: win/tclWin32Dll.c ================================================================== --- win/tclWin32Dll.c +++ win/tclWin32Dll.c @@ -21,22 +21,19 @@ * per-instance basis. Each time this DLL is loaded, it gets its own new data * segment with its own copy of all static and global information. */ static HINSTANCE hInstance; /* HINSTANCE of this DLL. */ -static int platformId; /* Running under NT, or 95/98? */ /* * VC++ 5.x has no 'cpuid' assembler instruction, so we must emulate it */ #if defined(_MSC_VER) && (_MSC_VER <= 1100) && defined (_M_IX86) #define cpuid __asm __emit 0fh __asm __emit 0a2h #endif -static Tcl_Encoding winTCharEncoding = NULL; - /* * The following declaration is for the VC++ DLL entry point. */ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, @@ -184,52 +181,19 @@ OSVERSIONINFOW os; hInstance = hInst; os.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); GetVersionExW(&os); - platformId = os.dwPlatformId; - - /* - * We no longer support Win32s or Win9x, so just in case someone manages - * to get a runtime there, make sure they know that. - */ - - if (platformId == VER_PLATFORM_WIN32s) { - Tcl_Panic("Win32s is not a supported platform"); - } - if (platformId == VER_PLATFORM_WIN32_WINDOWS) { - Tcl_Panic("Windows 9x is not a supported platform"); - } - - TclWinResetInterfaces(); -} - -/* - *---------------------------------------------------------------------- - * - * TclWinGetPlatformId -- - * - * Determines whether running under NT, 95, or Win32s, to allow runtime - * conditional code. - * - * Results: - * The return value is one of: - * VER_PLATFORM_WIN32s Win32s on Windows 3.1 (not supported) - * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95, 98, ME (not supported) - * VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000, XP - * VER_PLATFORM_WIN32_CE Win32 on Windows CE - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclWinGetPlatformId(void) -{ - return platformId; + + /* + * We no longer support Win32s or Win9x or Windows CE, so just in case + * someone manages to get a runtime there, make sure they know that. + */ + + if (os.dwPlatformId != VER_PLATFORM_WIN32_NT) { + Tcl_Panic("Windows NT is the only supported platform"); + } } /* *------------------------------------------------------------------------- * @@ -262,40 +226,14 @@ } /* *--------------------------------------------------------------------------- * - * TclpSetInterfaces -- - * - * A helper proc that initializes winTCharEncoding. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -void -TclpSetInterfaces(void) -{ - TclWinResetInterfaces(); - winTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); -} - -/* - *--------------------------------------------------------------------------- - * * 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. * * Side effects: @@ -307,12 +245,10 @@ void TclWinEncodingsCleanup(void) { MountPointMap *dlIter, *dlIter2; - TclWinResetInterfaces(); - /* * Clean up the mount point map. */ Tcl_MutexLock(&mountPointMap); @@ -323,34 +259,10 @@ ckfree(dlIter); dlIter = dlIter2; } Tcl_MutexUnlock(&mountPointMap); } - -/* - *--------------------------------------------------------------------------- - * - * TclWinResetInterfaces -- - * - * Called during finalization to reset us to a safe state for reuse. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ -void -TclWinResetInterfaces(void) -{ - if (winTCharEncoding != NULL) { - Tcl_FreeEncoding(winTCharEncoding); - winTCharEncoding = NULL; - } -} /* *-------------------------------------------------------------------- * * TclWinDriveLetterForVolMountPoint @@ -511,43 +423,36 @@ /* *--------------------------------------------------------------------------- * * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- * - * Convert between UTF-8 and Unicode when running Windows NT or the - * current ANSI code page when running Windows 95. - * - * On Mac, Unix, and Windows 95, all strings exchanged between Tcl and - * the OS are "char" oriented. We need only one Tcl_Encoding to convert - * between UTF-8 and the system's native encoding. We use NULL to - * represent that encoding. - * - * On NT, some strings exchanged between Tcl and the OS are "char" + * Convert between UTF-8 and Unicode when running Windows. + * + * On Mac and Unix, all strings exchanged between Tcl and the OS are + * "char" oriented. We need only one Tcl_Encoding to convert between + * UTF-8 and the system's native encoding. We use NULL to represent + * that encoding. + * + * On Windows, some strings exchanged between Tcl and the OS are "char" * oriented, while others are in Unicode. We need two Tcl_Encoding APIs * depending on whether we are targeting a "char" or Unicode interface. * - * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding of - * NULL should always used to convert between UTF-8 and the system's + * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding + * of NULL should always used to convert between UTF-8 and the system's * "char" oriented encoding. The following two functions are used in - * Windows-specific code to convert between UTF-8 and Unicode strings - * (NT) or "char" strings(95). This saves you the trouble of writing the + * Windows-specific code to convert between UTF-8 and Unicode strings. + * This saves you the trouble of writing the * following type of fragment over and over: * - * if (running NT) { - * encoding <- Tcl_GetEncoding("unicode"); - * nativeBuffer <- UtfToExternal(encoding, utfBuffer); - * Tcl_FreeEncoding(encoding); - * } else { - * nativeBuffer <- UtfToExternal(NULL, utfBuffer); - * } - * - * By convention, in Windows a TCHAR is a character in the ANSI code page - * on Windows 95, a Unicode character on Windows NT. If you plan on - * targeting a Unicode interfaces when running on NT and a "char" - * oriented interface while running on 95, these functions should be - * used. If you plan on targetting the same "char" oriented function on - * both 95 and NT, use Tcl_UtfToExternal() with an encoding of NULL. + * encoding <- Tcl_GetEncoding("unicode"); + * nativeBuffer <- UtfToExternal(encoding, utfBuffer); + * Tcl_FreeEncoding(encoding); + * + * By convention, in Windows a TCHAR is a Unicode character. If you plan + * on targeting a Unicode interface when running on Windows, these + * functions should be used. If you plan on targetting a "char" oriented + * function on Windows, use Tcl_UtfToExternal() with an encoding of NULL. * * Results: * The result is a pointer to the string in the desired target encoding. * Storage for the result string is allocated in dsPtr; the caller must * call Tcl_DStringFree() when the result is no longer needed. @@ -559,30 +464,51 @@ */ TCHAR * Tcl_WinUtfToTChar( const char *string, /* Source string in UTF-8. */ - int len, /* Source string length in bytes, or < 0 for + int len, /* Source string length in bytes, or -1 for * strlen(). */ Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - return (TCHAR *) Tcl_UtfToExternalDString(winTCharEncoding, - string, len, dsPtr); + TCHAR *wp; + int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0); + + Tcl_DStringInit(dsPtr); + Tcl_DStringSetLength(dsPtr, 2*size+2); + wp = (TCHAR *)Tcl_DStringValue(dsPtr); + MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1); + if (len == -1) --size; /* account for 0-byte at string end */ + Tcl_DStringSetLength(dsPtr, 2*size); + wp[size] = 0; + return wp; } char * Tcl_WinTCharToUtf( - const TCHAR *string, /* Source string in Unicode when running NT, - * ANSI when running 95. */ - int len, /* Source string length in bytes, or < 0 for + const TCHAR *string, /* Source string in Unicode. */ + int len, /* Source string length in bytes, or -1 for * platform-specific string length. */ Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - return Tcl_ExternalToUtfDString(winTCharEncoding, - (const char *) string, len, dsPtr); + char *p; + int size; + + if (len > 0) { + len /= 2; + } + size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL); + Tcl_DStringInit(dsPtr); + Tcl_DStringSetLength(dsPtr, size+1); + p = (char *)Tcl_DStringValue(dsPtr); + WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); + if (len == -1) --size; /* account for 0-byte at string end */ + Tcl_DStringSetLength(dsPtr, size); + p[size] = 0; + return p; } /* *------------------------------------------------------------------------ * Index: win/tclWinDde.c ================================================================== --- win/tclWinDde.c +++ win/tclWinDde.c @@ -150,17 +150,10 @@ { if (!Tcl_InitStubs(interp, "8.1", 0)) { 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); } Index: win/tclWinError.c ================================================================== --- win/tclWinError.c +++ win/tclWinError.c @@ -28,11 +28,11 @@ ENOMEM, /* ERROR_INVALID_BLOCK 9 */ E2BIG, /* ERROR_BAD_ENVIRONMENT 10 */ ENOEXEC, /* ERROR_BAD_FORMAT 11 */ EACCES, /* ERROR_INVALID_ACCESS 12 */ EINVAL, /* ERROR_INVALID_DATA 13 */ - EFAULT, /* ERROR_OUT_OF_MEMORY 14 */ + ENOMEM, /* ERROR_OUT_OF_MEMORY 14 */ ENOENT, /* ERROR_INVALID_DRIVE 15 */ EACCES, /* ERROR_CURRENT_DIRECTORY 16 */ EXDEV, /* ERROR_NOT_SAME_DEVICE 17 */ ENOENT, /* ERROR_NO_MORE_FILES 18 */ EROFS, /* ERROR_WRITE_PROTECT 19 */ Index: win/tclWinInit.c ================================================================== --- win/tclWinInit.c +++ win/tclWinInit.c @@ -82,19 +82,14 @@ */ TclWinProcs tclWinProcs; /* * The following arrays contain the human readable strings for the Windows - * platform and processor values. + * processor values. */ -#define NUMPLATFORMS 4 -static const char *const platforms[NUMPLATFORMS] = { - "Win32s", "Windows 95", "Windows NT", "Windows CE" -}; - #define NUMPROCESSORS 11 static const char *const processors[NUMPROCESSORS] = { "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" }; @@ -185,11 +180,11 @@ */ void TclpInitLibraryPath( char **valuePtr, - size_t *lengthPtr, + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 64 Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; @@ -348,11 +343,11 @@ */ static void InitializeDefaultLibraryDir( char **valuePtr, - size_t *lengthPtr, + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; @@ -399,11 +394,11 @@ */ static void InitializeSourceLibraryDir( char **valuePtr, - size_t *lengthPtr, + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; @@ -490,22 +485,15 @@ void 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) { Tcl_DStringInit(bufPtr); @@ -567,14 +555,11 @@ * Define the tcl_platform array. */ Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", TCL_GLOBAL_ONLY); - if (osInfo.dwPlatformId < NUMPLATFORMS) { - Tcl_SetVar2(interp, "tcl_platform", "os", - platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY); - } + Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY); wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); if (sys.oemId.wProcessorArchitecture < NUMPROCESSORS) { Tcl_SetVar2(interp, "tcl_platform", "machine", processors[sys.oemId.wProcessorArchitecture], Index: win/tclWinInt.h ================================================================== --- win/tclWinInt.h +++ win/tclWinInt.h @@ -38,23 +38,10 @@ BOOL (WINAPI *cancelSynchronousIo)(HANDLE); } TclWinProcs; MODULE_SCOPE TclWinProcs tclWinProcs; -/* - * Some versions of Borland C have a define for the OSVERSIONINFO for - * Win32s and for NT, but not for Windows 95. - * Define VER_PLATFORM_WIN32_CE for those without newer headers. - */ - -#ifndef VER_PLATFORM_WIN32_WINDOWS -#define VER_PLATFORM_WIN32_WINDOWS 1 -#endif -#ifndef VER_PLATFORM_WIN32_CE -#define VER_PLATFORM_WIN32_CE 3 -#endif - #ifdef _WIN64 # define TCL_I_MODIFIER "I" #else # define TCL_I_MODIFIER "" #endif Index: win/tclWinPipe.c ================================================================== --- win/tclWinPipe.c +++ win/tclWinPipe.c @@ -1093,44 +1093,27 @@ * If we are starting a GUI process, they don't automatically get a * console, so it doesn't matter if they are started as foreground or * detached processes. The GUI window will still pop up to the foreground. */ - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { - if (HasConsole()) { - createFlags = 0; - } else if (applType == APPL_DOS) { - /* - * Under NT, 16-bit DOS applications will not run unless they can - * be attached to a console. If we are running without a console, - * run the 16-bit program as an normal process inside of a hidden - * console application, and then run that hidden console as a - * detached process. - */ - - startInfo.wShowWindow = SW_HIDE; - startInfo.dwFlags |= STARTF_USESHOWWINDOW; - createFlags = CREATE_NEW_CONSOLE; - TclDStringAppendLiteral(&cmdLine, "cmd.exe /c"); - } else { - createFlags = DETACHED_PROCESS; - } - } else { - if (HasConsole()) { - createFlags = 0; - } else { - createFlags = DETACHED_PROCESS; - } - - if (applType == APPL_DOS) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "DOS application process not supported on this platform", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP", - NULL); - goto end; - } + if (HasConsole()) { + createFlags = 0; + } else if (applType == APPL_DOS) { + /* + * Under NT, 16-bit DOS applications will not run unless they can + * be attached to a console. If we are running without a console, + * run the 16-bit program as an normal process inside of a hidden + * console application, and then run that hidden console as a + * detached process. + */ + + startInfo.wShowWindow = SW_HIDE; + startInfo.dwFlags |= STARTF_USESHOWWINDOW; + createFlags = CREATE_NEW_CONSOLE; + TclDStringAppendLiteral(&cmdLine, "cmd.exe /c"); + } else { + createFlags = DETACHED_PROCESS; } /* * cmdLine gets the full command line used to invoke the executable, * including the name of the executable itself. The command line arguments Index: win/tclWinSerial.c ================================================================== --- win/tclWinSerial.c +++ win/tclWinSerial.c @@ -1736,11 +1736,11 @@ */ dcb.XonChar = argv[0][0]; dcb.XoffChar = argv[1][0]; if (argv[0][0] & 0x80 || argv[1][0] & 0x80) { - Tcl_UniChar character; + Tcl_UniChar character = 0; int charLen; charLen = Tcl_UtfToUniChar(argv[0], &character); if (argv[0][charLen]) { goto badXchar; Index: win/tclWinSock.c ================================================================== --- win/tclWinSock.c +++ win/tclWinSock.c @@ -358,11 +358,11 @@ */ void InitializeHostName( char **valuePtr, - size_t *lengthPtr, + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; DWORD length = MAX_COMPUTERNAME_LENGTH + 1; Tcl_DString ds; Index: win/tclWinThrd.c ================================================================== --- win/tclWinThrd.c +++ win/tclWinThrd.c @@ -11,12 +11,10 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" -#include - /* Workaround for mingw versions which don't provide this in float.h */ #ifndef _MCW_EM # define _MCW_EM 0x0008001F /* Error masks */ # define _MCW_RC 0x00000300 /* Rounding */ # define _MCW_PC 0x00030000 /* Precision */